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

Excel 2010

我知道还有其他类似的问题，但这是我使用的代码的特定问题。 我一直在试图修改这个VBA脚本来适应我的目的，但到目前为止我还没有成功。 代码需要将重复值剪切并粘贴到同一行的另一列中。 如A2，A3，A4中有重复，则B3，B4的内容需要进入C2，D2。

Sub CheckDupl() Dim x, i, nD As Integer Dim c As String Dim nLimit As Integer Dim bFound As Boolean nLimit = 6 '--> you can change this nD = 2 '--> start row For x = 1 To 3 'Cells(x, 6) = "x" c = Cells(x, 1) bFound = False For n = x + 1 To nLimit If Not Cells(n, 6) = "x" Then If Cells(n, 1) = c Then If Not bFound Then bFound = True Cells(nD, 3) = Cells(x, 2) 'Cells(nD, 4) = Cells(x, 3) 'Cells(nD + 1, 3) = Cells(n, 2) Cells(nD, 4) = Cells(n, 2) 'Cells(n, 6) = "x" nD = nD Else 'Cells(nD, 5) = Cells(n, 2) Cells(nD, 5) = Cells(n, 2) 'Cells(n, 6) = "x" nD = nD + 1 End If End If End If Next Next End Sub 

我原则上已经做了我所需要的，但是它不会在工作表中下移。 这是一个示例工作簿 。 我怎样才能让它遍历列，只粘贴我需要的行？

因此，在A行有重复的地方，比如梨，A3和A4需要和第一次出现在同一行，比如C2和D2。 这个范围相当长，约1200行

Answer 1

我没有真正能够遵循你的代码，而且我不愿意下载工作簿，但我已经做了这个你可以调整的：

 Sub test() 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 = False ' 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(Cells(2, 1), Cells(lastRow, 2)) Else Set rng = Range(Cells(1, 1), Cells(lastRow, 1)) Set sortRng = Range(Cells(1, 1), Cells(lastRow, 2)) 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 = xlGuess .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 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(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete k = 0 lastRow = Cells(1, 1).End(xlDown).Row End If Next i End With End Sub 

这对我如何工作：我有列A和B中的数据：

注意：我没有标题。 我使用列A作为具有可能重复值的列。 首先，按Asorting，按顺序获得所有的数字（或字，如果按字母顺序）。 这将有所有重复在一起。 那么，它通过A列中的每个单元格查看，如果该单元格的值超过1，则移动“B”信息。 到“C”：

如果您可以发布屏幕截图，或者让我知道您的数据在哪里，那么可以轻松调整以包含更多单元格，其他范围等。

编辑：快速的方式来通过列循环，只是FYI：

 Sub test() Dim rng As Range, cel As Range rng = ("A1:A100") For Each cel In rng cel.Select ' Do whatever in the cell. After this is done, it'll go to the next one ' I chose to Select the cell because it helps me when debugging, to make sure I selected the right cells. You can (should) comment that out when you know it works. Next cel End Sub