Question

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

我已经让它在原则上做了我需要的东西，但它不会向下移动工作表。 Here is a sample workbook。如何让它循环遍历列并仅粘贴我需要的行？

因此，如果行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列中有数据：

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

如果您可以发布截图，或者只是告诉我数据的位置，可以轻松调整以包含更多单元格，其他范围等。

编辑：循环遍历列的快捷方式，仅供参考：

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

如果找到重复，则复制相邻单元格的VBA脚本

1 个答案: