VBA脚本复制同一行的相邻单元格，如果发现重复

Question

Sub test()

Dim lastRow作为Integer，i作为Integer Dim cel作为Range,rng作为Range,sortRng作为Range Dim curString作为String,nextString作为String Dim haveHeaders作为Boolean

haveHeaders=False‘如果有header将其更改为TRUE。

lastRow=单元格（1,1).end（xlDown）.行

' Now, let's move all "Column B" data for duplicates into Col. C

' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer

If haveHeaders Then
    curString = Cells(2, 1).Value
Else
    curString = Cells(1, 1).Value
End If

Dim dupRng As Range      'set the range for the duplicates
Dim k   As Integer

k = 0
For i = 1 To lastRow
    If i > lastRow Then Exit For
    Cells(i, 1).Select
    curString = Cells(i, 1).Value
    nextString = Cells(i + 1, 1).Value
    isDuplicate = WorksheetFunction.CountIf(rng, Cells(i, 1).Value)


    If isDuplicate > 1 Then
        firstInstanceRow = i
        Do While Cells(i, 1).Offset(k, 0).Value = nextString
            'Cells(i, 1).Offset(k, 0).Select
            lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
            k = k + 1
        Loop

        Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
        Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
        k = 0
        lastRow = Cells(1, 1).End(xlDown).Row
    End If

   Next i

End With

End Sub

改变了这个：

Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 2)).Copy
Cells(firstInstanceRow, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False

到

Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
Application.CutCopyMode = False

我所拥有的是：

Column A  Column B  column C
 322       sku322    qty 20
 322       322sku    qty 25

Column D   column E
 sku322     qty 20
 322sku     qty 25

Column D   Column E
 sku322     322sku
 qty 20     qty 25

Answer 1

这是怎么回事？成绩截图：

注意：如果您想要整个'unique-sku'列而不仅仅是国家代码，请更改

country = Right(Cells(i, 2), 2)

到

country = Cells(i, 2).Value

Sub Macro1()
'
' Macro1 Macro
'
    Dim country As String, qty As Integer
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

    ' Headers
    dict("country") = "sum"

    ' Loop through all rows starting on row 2; per Column A
    For i = 2 To Sheets("Sheet1").Cells(1, 1).End(xlDown).Row
        ' Country = last 2 letters of Column B
        country = Right(Cells(i, 2), 2)
        qty = CInt(Cells(i, 3).Value)

        ' If it already exists, add the new amount to the sum.
        If dict.Exists(country) Then
            qty = dict(country) + qty
        End If

        ' This will create it if it doesn't already exist. Otherwise, update.
        dict(country) = qty
    Next

        ' Here are some display options.
        ' Horizontal
        Range("F2").Resize(1, UBound(dict.Keys()) + 1).Value = dict.Keys()
        Range("F3").Resize(1, UBound(dict.Items()) + 1).Value = dict.Items()
        ' Vertical
        Range("F5").Resize(UBound(dict.Keys()) + 1).Value = WorksheetFunction.Transpose(dict.Keys())
        Range("G5").Resize(UBound(dict.Items()) + 1).Value = WorksheetFunction.Transpose(dict.Items())

    Set dict = Nothing
'
End Sub