有什么快速的方法可以通过分析 Excel VBA 中的多列将重复行（彼此相邻）从 Sheet 复制到另一个？

Question

我想通过分析 excel 中的多列将重复行从 sheet 复制到另一行，我可以通过应用嵌套 For 循环来比较多列但我的行数sheet 大约是 6000。因此，如果我应用嵌套的 For 循环来通过分析 2 列来比较行，它需要大约 17991001 次迭代，这会减慢我的系统。有什么快速的方法吗？？？

我的函数是

Sub findDuplicates(ByVal sheet As Worksheet, name As String, ByRef row As Integer, ByVal Sheet2 As Worksheet)
    Dim i As Integer
    Dim numRow As Integer
    'Dim matchFound As Long
    'Dim myRange1 As Range
    'Dim myRange2 As Range



    numRow = sheet.Range("J2", sheet.Range("J2").End(xlDown)).Rows.Count

    With Sheet2
        Range(Cells(row, "A"), Cells(row, "N")).MergeCells = True
        With Cells(row, "A")
            .Font.name = "Bell MT"
            .Font.FontStyle = "Bold Italic"
            .Font.Size = 20
            .Font.Color = RGB(255, 99, 71)
            .Value = "Multiple Forms Found in " & name & " for single household"
        End With
        row = row + 1
    End With
        For i = 1 To numRow + 1
            'matchFound
            'If i <> matchFound Then
            sheet.Rows(i).Copy Sheet2.Rows(row)
            row = row + 1
            'sheet.Rows(matchFound).Copy Sheet2.Rows(row)
            'row = row + 1
           'End If

        Next i
End Sub

注意 - 我添加了一些评论以使您了解我想要做什么。

我的函数的总结是取两个 sheet 并检查 sheet 的 J 和 K 列 1，如果两行找到相同的 J 和 K 列的值，则复制这两行至 sheet2（彼此相邻）

Answer 1

试试这个。修改自 Siddharth Rout 的回答 here.

Private Sub CommandButton2_Click()
    Dim col As New Collection
    Dim SourceSheet As Worksheet
    Dim DestSheet As Worksheet
    Dim i As Long
    Dim lLastRow As Long

    Application.ScreenUpdating = False

    Set SourceSheet = ThisWorkbook.Sheets("Sheet1")
    Set DestSheet = Worksheets("Sheet2")
    lLastRow = SourceSheet.Cells(Rows.Count, 10).End(xlUp).row

    DestSheetLastRow = 1
    With SourceSheet
        For i = 1 To lLastRow
            On Error Resume Next
            col.Add i, CStr(.Range("J" & i).Value) 'Add elements to collection
            If Err.Number <> 0 Then 'If element already present
                TheVal = CStr(SourceSheet.Range("J" & i).Value) 'Get the duplicate value
                TheIndex = col(TheVal) 'Get the original position of duplicate value in the collection (i.e., the row)
                If (.Cells(i, 11).Value = .Cells(TheIndex, 11).Value) Then 'Check the other column (K). If same value...
                    SourceSheet.Range(Cells(TheIndex, 1), Cells(TheIndex, 20)).Copy DestSheet.Cells(DestSheetLastRow, 1) 'Set your range according to your needs. 20 columns in this example
                    SourceSheet.Range(Cells(i, 1), Cells(i, 20)).Copy DestSheet.Cells(DestSheetLastRow, 21)
                    DestSheetLastRow = DestSheetLastRow + 1
                    Err.Clear
                End If
            End If
        Next i
    End With

    Application.ScreenUpdating = True
End Sub

Answer 2

最后，这对我有用

Sub findDuplicates(ByVal sheet As Worksheet, name As String, ByRef row As Integer, ByVal Sheet2 As Worksheet)
    Dim i As Integer
    Dim j As Integer
    Dim numRow As Integer
    Dim count As Integer 
    Dim myRange1 As Range
    Dim myRange2 As Range
    Dim myRange3 As Range

    Set myRange1 = sheet.Range("J2", sheet.Range("J2").End(xlDown)).Rows
    Set myRange2 = sheet.Range("K2", sheet.Range("K2").End(xlDown)).Rows
    numRow = sheet.Range("J2", sheet.Range("J2").End(xlDown)).Rows.count

    With Sheet2
        Range(Cells(row, "A"), Cells(row, "N")).MergeCells = True
        With Cells(row, "A")
            .Font.name = "Bell MT"
            .Font.FontStyle = "Bold Italic"
            .Font.Size = 20
            .Font.Color = RGB(255, 99, 71)
            .Value = "Multiple Forms Found in " & name & " for single household"
        End With
        sheet.Rows(1).Copy .Rows(row + 1)
        .Rows(row + 1).WrapText = False
        row = row + 2
    End With
    j = row
    For i = 1 To numRow + 1
        count = WorksheetFunction.CountIfs(myRange1, sheet.Cells(i, "J"), myRange2, sheet.Cells(i, "K"))
        If count > 1 Then
            sheet.Rows(i).Copy Sheet2.Rows(row)
            row = row + 1
        End If
    Next i

    Set myRange3 = Sheet2.Range(Cells(j, 1), Cells(row - 1, 192))
    With Sheet2.Sort
       .SortFields.Add Key:=Range("J1"), Order:=xlAscending
       .SortFields.Add Key:=Range("K1"), Order:=xlAscending
       .SetRange myRange3
       .Header = xlNo
       .Orientation = xlTopToBottom
       .Apply
    End With    
End Sub

有什么快速的方法可以通过分析 Excel VBA 中的多列将重复行（彼此相邻）从 Sheet 复制到另一个？

Is there any fast way to copy Duplicate rows(next to each other) from a Sheet to another by analyzing multiple columns in Excel VBA?

vba

excel

excel-2016