VBA脚本，用于在发现重复时复制同一行上的相邻单元格_Vba_Excel

VBA脚本，用于在发现重复时复制同一行上的相邻单元格

vba excel

VBA脚本，用于在发现重复时复制同一行上的相邻单元格,vba,excel,Vba,Excel,我只在一个点上修改了代码，因为这是我需要的，但我需要一些额外的东西，我不知道怎么做以下是post的原始代码： Dim lastRow为整数，i为整数调光cel As Range、rng As Range、sortRng As Range Dim curString作为字符串，nextString作为字符串将标题设置为布尔值 haveHeaders=False“如果有标题，请将其更改为TRUE lastRow=单元格（1，1）.End（xlDown）.Row 如果haveHeaders，那么

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

以下是post的原始代码：

Dim lastRow为整数，i为整数调光cel As Range、rng As Range、sortRng As Range Dim curString作为字符串，nextString作为字符串将标题设置为布尔值

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

lastRow=单元格（1，1）.End（xlDown）.Row

如果haveHeaders，那么“如果您有标题，我们将从第2行的范围开始设置rng=范围（单元格（2，1），单元格（最后一行，1））设置sortRng=范围（单元格（2，1），单元格（最后一行，2））其他的设置rng=范围（单元格（1，1），单元格（最后一行，1））设置sortRng=范围（单元格（1，1），单元格（最后一行，2））如果结束 '首先，让我们利用您的数据，按顺序获取所有“A列”值，这将把所有重复项分组在一起

使用ActiveSheet .Sort.SortFields.Clear .Sort.SortFields.Add Key:=rng，SortOn:=xlSortOnValues，Order:=xlAscending，DataOption:=xlSortNormal 用。排序 .SetRange sortRng .Header=xlGuess .MatchCase=False .方向=xlTopToBottom .SortMethod=xl拼音 .申请以

' 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

到

我得到的是：

列A有重复项。列B具有唯一的值。列C有唯一值的数量。 I它一直工作到复制和粘贴部分，但它从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

然后删除最后一行，我就没有数量了。按照我的想法，如果没有办法粘贴到同一行，那就意味着在每次查找之后，它应该重新执行循环，而不是批量复制/粘贴。但我尝试了多种方法，但似乎找不到一种方法让它起作用。

提前谢谢你的帮助。

这是怎么回事？结果截图：

注意：如果您想要完整的“唯一sku”列，而不仅仅是国家/地区代码，请更改

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

到

代码：

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

所以我找到了一个解决方法，我不知道它是否是最可行的，但它可以工作，对于10000行，它最多在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

Private Sub-SameRowDuplicates（）
Dim lastRow为整数，i为整数
调光cel As Range、Rng As Range、sortRng As Range
Dim curString作为字符串，nextString作为字符串
将标题设置为布尔值
haveHeaders=True“如果有标题，请将其更改为True。
lastRow=单元格（1，1）.End（xlDown）.Row
如果haveHeaders，那么“如果您有标题，我们将从第2行的范围开始
设置Rng=范围（单元格（2，1），单元格（最后一行，1））
设置sortRng=范围（“A2”）。当前区域
其他的
设置Rng=范围（单元格（1，1），单元格（最后一行，1））
设置sortRng=范围（“A1”）。当前区域
如果结束
'首先，让我们利用您的数据，按顺序获取所有“A列”值，这将把所有重复项分组在一起
使用ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Rng，SortOn:=xlSortOnValues，Order:=xlAscending，DataOption:=xlSortNormal
用。排序
.SetRange sortRng
.Header=xlYes
.MatchCase=False
.方向=xlTopToBottom
.SortMethod=xl拼音
.申请
以
现在，让我们将所有重复的“B列”数据移到C列中
我们可以通过简单地计算单元格在“rng”中出现的次数来检查单元格的值是否重复`
Dim作为整数复制，firstInstanceRow作为整数，lastInstanceRow作为整数
如果有的话
curString=单元格（2，1）.Value
其他的
curString=单元格（1，1）.Value
如果结束
Dim dupRng As Range“设置复制品的范围
将k变为整数
k=0
对于i=1到最后一行
如果i>lastRow，则退出
单元格（i，1）。选择
curString=单元格（i，1）.Value
nextString=单元格（i+1，1）.Value
isDuplicate=工作表函数.CountIf（Rng，单元格（i，1）.Value）
如果isDuplicate>1，则
firstInstanceRow=i
直到单元格（i，1）.偏移量（k，0）.值下一个字符串
'单元格（i，1）.偏移量（k，0）.选择
lastInstanceRow=单元格（i，1）.偏移量（k，0）.行
k=k+1
环
单元格（firstInstanceRow，5）。公式=“=Combine（&Range（单元格（firstInstanceRow+1，2），单元格（lastInstanceRow，3））。Address（False，False）&”）”将结果合并到一行中，以便一个接一个地获得所有重复项
单元格（firstInstanceRow，5）。复制
单元格（firstInstanceRow，5）.Paste特殊粘贴：=xlPasteValues，操作：=xlNone，SkipBlank:=False
Application.CutCopyMode=False
Selection.TextToColumns数据类型：=xlDelimited，\用于将逗号分隔的列转换为列
ConcertiveDelimiter:=False，分号：=True'在这里，您应该将分隔符更改为您正在使用的分隔符
范围（行（firstInstanceRow+1），行（lastInstanceRow））.EntireRow.Delete
k=0
lastRow=单元格（1，1）.End（xlDown）.Row
如果结束
接下来我
以
端接头

职能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

函数组合（工作范围为，可选符号为String=“；”）为String
'更新20130815
变暗Rng As范围
像线一样暗的伸出
对于WorkRng中的每个Rng
如果Rng.Text“；”则
outsr=outsr&Rng.文本和符号
如果结束
下一个
联合收割机=左（伸出，长（伸出）-1）
端函数

这么快的故事：模块1调用其他模块，我这样做是为了让t更容易

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

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

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