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

Question

我只修改了一次代码，因为这是我需要的，但我需要一些额外的东西，但我不知道该怎么做。

这是this帖子的原始代码：

Sub test()

将 lastRow 设为整数，i 设为整数 Dim cel As Range, rng As Range, sortRng As Range 将 curString 调暗为字符串，将 nextString 调为字符串 将 hasHeaders 调暗为布尔值

haveHeaders = False ' 如果您有标题，请将其更改为 TRUE。

lastRow = Cells(1, 1).End(xlDown).Row

If haveHeaders Then '如果你有标题，我们将在第 2 行开始范围 设置 rng = Range(Cells(2, 1), Cells(lastRow, 1)) 设置 sortRng = Range(Cells(2, 1), Cells(lastRow, 2)) 别的 设置 rng = Range(Cells(1, 1), Cells(lastRow, 1)) 设置 sortRng = Range(Cells(1, 1), Cells(lastRow, 2)) 万一 ' 首先，让我们利用您的数据，按顺序获取所有“A 列”值，这会将所有重复项组合在一起

使用 ActiveSheet .Sort.SortFields.Clear .Sort.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 使用 .Sort .SetRange sortRng .Header = xlGuess .MatchCase = 假 .Orientation = xlTopToBottom .SortMethod = xlPinYin 。申请 结束于

' 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

我拥有的是：

A 列有重复项。 B 列具有独特的价值。 并且 C 列具有唯一值的数量。 我一直工作到复制和粘贴部分，除了它从 B 列的值复制列 C 或另一种方式是它从列 B 复制每个值和列 C 的数量，但是当它完成时，它会删除所有重复。

例子

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

Answer 2

所以我找到了一种解决方法，我不知道它是否是最可行的解决方法，但它可以工作，并且对于 10.000 行，它最多可以在 40 秒到 1 分钟内完成。

你需要创建3个模块和一个函数（我不想把函数放在模块上。

模块 1

Sub Simplify()

Application.Run "Module9.RemovePart"
Application.Run "Module10.SameRowDuplicates"

End Sub

模块 2

Private Sub RemovePart()
Dim fndList As Variant
Dim fndRplc As Variant

With ActiveSheet
Range("B1").EntireColumn.Insert 'Here i inserted a new column so i can duplicate the first column
Range("A1", Range("A" & Rows.Count).End(xlUp)).Copy ' Copied the first column to the inserted one
Range("B1", Range("B" & Rows.Count).End(xlUp)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
        Application.CutCopyMode = False

lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' selected first column to remove the end of the sku
fndList = Array("FR", "DE", "ES") ' here you can just change to whatevery you want to remove
fndRplc = "" ' here is what it replaces it with


  For x = LBound(fndList) To UBound(fndList)


For i = lastRow To 1 Step -1
    Range("A1").EntireColumn.Replace What:=fndList(x), Replacement:=fndRplc, _
        LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
 Next i

Next x

End With

End Sub

模块 3

Private Sub SameRowDuplicates()
Dim lastRow As Integer, i As Integer
Dim cel As Range, Rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean

haveHeaders = True          ' Change this to TRUE if you have headers.

lastRow = Cells(1, 1).End(xlDown).Row

If haveHeaders Then          'If you have headers, we'll start the ranges in Row 2
    Set Rng = Range(Cells(2, 1), Cells(lastRow, 1))
    Set sortRng = Range("A2").CurrentRegion
Else
    Set Rng = Range(Cells(1, 1), Cells(lastRow, 1))
    Set sortRng = Range("A1").CurrentRegion
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together

With ActiveSheet
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange sortRng
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

' 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 Until 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

        Cells(firstInstanceRow, 5).Formula = "=Combine(" & Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Address(False, False) & ")" ' combine the results in one row so you have all the duplicates one after another
        Cells(firstInstanceRow, 5).Copy
        Cells(firstInstanceRow, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
        Application.CutCopyMode = False
        Selection.TextToColumns DataType:=xlDelimited, _ ' this is for converting comma delimited to columns
        ConsecutiveDelimiter:=False, Semicolon:=True ' here you should change your delimiter to what you are using
        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

功能 1

Function Combine(WorkRng As Range, Optional Sign As String = ";") As String
'Update 20130815
Dim Rng As Range
Dim OutStr As String
For Each Rng In WorkRng
    If Rng.Text <> ";" Then
        OutStr = OutStr & Rng.Text & Sign
    End If
Next
Combine = Left(OutStr, Len(OutStr) - 1)
End Function

这么快的故事： 模块 1 调用其他模块，我这样做是为了让最终用户更轻松，这样他就不会看到所有模块，只需单击一个即可。 模块 2 从选定单元格中删除任何文本 模块 3 查找重复项并将它们放在由您在功能模块中选择的内容分隔的一行中。然后删除重复行。 函数 1 获取您选择的输出并将其放在分隔的一行中。

就是这样，感谢大家的帮助，我希望这对其他人有所帮助。