Question

我想通过分析excel中的多个列将一个工作表中的重复行复制到另一个，我可以通过应用Nested For循环来比较多个列但我的工作表中的行数大约为6000.所以如果我应用嵌套对于通过分析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

注意 - 我添加了一些注释，以帮助您了解我想要做的事情。

我的函数的总结是取两张纸并检查表1的J和K列，如果两行找到相同的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中的多个列，将重复行（彼此相邻）从工作表复制到另一个？

2 个答案: