0

我有一张包含大量数据的工作表（sheet1）。此数据有几列，其中一列称为 nameColumn。nameColumn 每行包含一个单词。

在表 2 中，我有一个 600 个单词的列表。

我需要从 sheet1 中删除包含 nameColumn 中与 sheet2 中的单词匹配的单词的每一行

我已经按 nameColumn 的字母顺序对 sheet1 进行了排序，并且还按字母顺序对 sheet2 进行了排序。

我编写的代码有效，但非常糟糕。它为工作表 1 中的行数创建一个 for 循环，以及一个嵌套在其中的 while 循环，用于比较两个工作表之间的值，如果在 nameColumn 中找到匹配项，则删除该行。我尝试通过告诉 while 循环仅在 sheet1 中所讨论的单词按字母顺序“大于”sheet2 中的单词时才增加“i”来“优化”它。

这段代码需要 20 分钟才能完成大约 10k 行。我怎样才能让它更快？

请注意，我尝试更改代码以将不匹配的行复制到另一张工作表，这似乎很慢。我也看过这篇文章Excel / VBA Remove duplicate rows by cross reference 2 different sheet 然后删除 1 row，坦率地说，我对它的理解还不够，无法尝试实现它。

Sub removerows3()
Application.ScreenUpdating = False

Dim numberof_data_rows As Long
numberof_data_rows = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

Dim numberof_alert_rows As Long
numberof_alert_rows = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row

Dim nameColumn As Integer
nameColumn = 3 

Dim current_alert_row As Integer
current_alert_row = 2

Dim current_data_row As Long
current_data_row = 2

Dim keep_searching_dosealert As Integer
keep_searching_dosealert = 1


For current_data_row = 2 To numberof_data_rows


Do While keep_searching_dosealert = 1
    If Sheet2.Cells(current_alert_row, 1) = Cells(current_data_row, nameColumn) 
        Cells(current_data_row, nameColumn).EntireRow.Delete
        keep_searching_dosealert = 0
        current_data_row = current_data_row - 1
        numberof_data_rows = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

    ElseIf StrComp(Sheet2.Cells(current_alert_row, 1), Sheet1.Cells(current_data_row, nameColumn)) = 1 Then 
        keep_searching_dosealert = 0
        current_alert_row = current_alert_row - 1

    ElseIf StrComp(Sheet2.Cells(current_alert_row, 1), Sheet1.Cells(current_data_row, nameColumn)) = -1 Then 
        keep_searching_dosealert = 1
        current_alert_row = current_alert_row + 1
    Else
        MsgBox ("error")

    End If
Loop
keep_searching_dosealert = 1


Next current_data_row

End Sub
4

2 回答 2

1

请参阅以下代码中的注释。它在 Sheet1 右侧的列中创建一个临时数组公式。它是我们正在检查的列右侧的 20 列 - 如有必要，请增加此数字。

Sub DeleteAcross2()
    Dim calc As Variant
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim dels As Variant
    Dim x As Long
    Dim rngDel As Range

    Application.ScreenUpdating = False
    'remember the Calculation Mode to reinstate later
    calc = Application.Calculation
    Application.Calculation = xlCalculationManual

    Set ws1 = Worksheets("Sheet1")
    Set rng1 = ws1.Range("B2:B70")      'change this range
    Set ws2 = Worksheets("Sheet2")
    Set rng2 = ws2.Range("A1:A4")       'change this range

    'add a formula-column 20 columns to the right - increase this number if necessary
    rng1.Offset(0, 20).FormulaArray = "=ISNA(MATCH(Sheet1!$B$2:$B$70,Sheet2!$A$1:$A$4,0))"
    'creates a column of True/False values - we will delete rows with False
    dels = rng1.Offset(0, 20).Value
    For x = 1 To UBound(dels, 1)
        If dels(x, 1) = False Then
            If rngDel Is Nothing Then
                Set rngDel = rng1.Cells(x, 1)       'the first cell
            Else
                Set rngDel = Union(rngDel, rng1.Cells(x, 1))
            End If
        End If
    Next x
    rng1.Offset(0, 20).Clear        'remove the array-formula (required)
    If rngDel Is Nothing Then Exit Sub      'no matches found
    rngDel.EntireRow.Delete
    Application.Calculation = calc
    Application.ScreenUpdating = True
End Sub

运行不需要 20 分钟 :)

于 2013-07-14T06:56:55.520 回答
0

下面的代码不是删除带有匹配单词的 Sheet1 数据的行，而是在 Sheet3 中创建数据的新副本——不包括带有匹配单词的行。接下来的步骤是删除 Sheet1 并重命名和移动 Sheet3（我没有在代码中包含这些步骤）。

该代码将 Sheet1 中的 nameColumn 和 Sheet2 中的 wordColumn 复制到 VBA 数组中。它循环遍历 nameColumn 数组，在 wordColumn 数组中搜索匹配项。为了加快匹配过程，Sheet2 中的单词列表在匹配之前进行了排序。找到匹配项时，在结果数组中设置标志值 1。

然后它将结果数组写回 Sheet1 并在 Sheet1 数据范围上设置自动过滤器以排除具有匹配单词的行。最后一步是将过滤后的数据复制到 Sheet3。

我在包含 26 列随机数字数据的 42,000 个单词的 nameColumn 上测试了代码，与从 nameColumn 单词中随机抽取的 600 个单词的排序列表相匹配。代码运行大约需要 5 秒，其中 80% 的时间用于单词匹配循环。（我还测试了一个删除匹配行的代码版本，这一更改使执行时间增加了一倍。）

Sub FilterOnNoMatchAndCopy()

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim ws1LastCell As Range, ws2LastCell As Range
    Dim valueArr(), searchArr(), resultArr()
    Dim i As Long, j As Long
    Dim sort_Sheet2_list As Boolean

    sort_Sheet2_list = True

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
    Set ws2 = ActiveWorkbook.Worksheets("Sheet2")

'   create Sheet3 if it doesn't exist, clear it if it does
    Set ws3 = Nothing
    On Error Resume Next
    Set ws3 = ActiveWorkbook.Worksheets("Sheet3")
    On Error GoTo 0
    If ws3 Is Nothing Then
        Worksheets.Add(After:=ws2).Name = "Sheet3"
        Set ws3 = ActiveWorkbook.Worksheets("Sheet3")
    End If
    ws3.Cells.Clear

'   Find last cell in used ranges
    With ws1
        Set ws1LastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
            .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column)
    End With
    With ws2
        Set ws2LastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _
            .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column)
    End With

'   copy the nameColumn and wordColumn into VBA arrays 
'   (if nameColumn and wordColumn are not in column A, change here)     
    valueArr = ws1.Range("$A$2:$A$" & ws1LastCell.Row)
    If sort_Sheet2_list Then
        ws2.Range("$A$2:$A$" & ws2LastCell.Row).Sort Key1:=ws2.Range("A2"), _
            Order1:=xlAscending, Header:=xlNo
    End If
    searchArr = ws2.Range("$A$2:$A$" & ws2LastCell.Row)

'   create a new array that will flag which words in nameColumn are matches
    ReDim resultArr(LBound(valueArr, 1) To UBound(valueArr, 1), 1 To 1)

'  search for matches 
   For i = 1 To UBound(valueArr, 1)
        j = 1
        Do While j < (UBound(searchArr, 1) + 1)
            If valueArr(i, 1) > searchArr(j, 1) Then
                j = j + 1
            Else
                If valueArr(i, 1) = searchArr(j, 1) Then
                    resultArr(i, 1) = 1
                End If
                j = UBound(searchArr, 1) + 1
            End If
        Loop
    Next

'   write match results to Sheet1, set autofilter to exclude matches, 
'       and copy result to Sheet3
    With ws1
        .Cells(1, ws1LastCell.Column + 1).value = "found"
        .Range(.Cells(2, ws1LastCell.Column + 1), _
            .Cells(ws1LastCell.Row, ws1LastCell.Column + 1)) = _
            resultArr
        .Range("A1").AutoFilter ws1LastCell.Column + 1, "<>1"
        .Range(.Cells(1, 1), .Cells(ws1LastCell.Row, ws1LastCell.Column)).Copy Destination:=ws3.Range("A1")
        .AutoFilterMode = False
        .Cells(1, ws1LastCell.Column + 1).EntireColumn.Delete
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub
于 2013-07-15T03:30:31.327 回答