代码之家 › 专栏 › 技术社区 › Shivam

通过分析Excel VBA中的多列,有没有快速的方法将重复的行(彼此相邻)从一个工作表复制到另一个工作表?

excel-2016 excel vba

Shivam · 技术社区 · 7 年前

我想通过分析excel中的多列将重复行从一个工作表复制到另一个工作表,我可以通过应用嵌套For循环来比较多列,但我的工作表中的行数约为6000。因此,如果我通过分析2列来应用nested For循环来比较行,则需要大约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列的值相同,则两行都复制到表2(彼此相邻)

2 回复 | 直到 7 年前

CMArg 7 年前

试试这个。根据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

Shivam 7 年前

最后,这对我有用

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