有人可以帮我缩短这段代码吗？

时间：2021-02-13 12:50:53

标签： excel vba search

我有一个很大的包含订单信息的 excel。 我的目标是在“客户名称列”(H:H) 中找到基于关键字的商业地址订单，然后将找到值的行复制到新工作表中。

有一个关键词列表，但由于我不知道如何在 VBA 中使用它，我只有一个代码，只要我复制粘贴代码并编写一个新的代码，它就会根据每个单词重复搜索要搜索的值/单词。 确定关键字后，整行将复制到工作表 3 中。工作表 1 包含原始数据，工作表 2 包含每个单词的列表我不知道如何运行将它们包含在搜索中的代码，而无需我每次都一一写。

Sub Commercial()

Dim cell As Range

With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "gmbh") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "studio") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "solution") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "büro") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "consult") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "firma") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "system") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "computer") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "department") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "bmw") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "bank") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "anwalt") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "finance") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "filiale") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "software") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "ihk") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "international") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "embassy") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "konsulat") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "mobil") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "Dr.") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "praxis") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "partner") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "market") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
        With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, "indust") > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
End Sub

3 个答案:

答案 0 :(得分：1)

从搜索词列表中构建 regular expression 模式。我假设这些在第 2 页的 A 列中，从第 1 行开始。

main.py

答案 1 :(得分：1)

您可以使用数组：

Dim Cell    As Range
Dim Words   As Variant
Dim Index   As Integer

Words = Array("gmbh", "solution", ..etc. .., "indust")
With Sheets(1)
    For Each Cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        For Index = LBound(Words) To UBound(Words)
            If InStr(Cell.Value, Words(Index)) > 0 Then
                .Rows(Cell.Row).Copy Destination:=Sheets(3).Rows(Cell.Row)
            End If
        Next
    Next
End With

答案 2 :(得分：1)

请测试下一个代码。它使用数组，仅在内存中工作并且应该非常快。它不会复制所有行，而是复制 Sheets(1) 现有列值：

Sub Commercial()
  Dim sh1 As Worksheet, sh3 As Worksheet, lastR As Long, lastCol As Long
  Dim i As Long, j As Long, k As Long, arr1, arr3, arrCond, El
  
  'create an array of the necessary string conditions:
  arrCond = Split("gmbh,studio,solution,büro,consult,firma,system,computer,department,bmw,bank,anwalt,finance,filiale,software,ihk,international,embassy,konsulat,mobil,Dr.,praxis,partner,market,indust", ",")
  
  Set sh1 = whorsheets(1) 'use here the necessary sheet
  Set sh3 = Worksheets(3) 'use here the necessary sheet
  lastR = sh1.Range("H" & sh1.Rows.count).End(xlUp).row 'last row of Sheet1
  lastCol = sh1.cells(1, sh1.Columns.count).End(xlToLeft).Column 'last column of Sheet1
  
  arr1 = sh1.Range("A2", sh1.cells(lastR, lastCol)).Value 'put the range in an array
  ReDim arr3(1 To lastCol, 1 To UBound(arr1)) 'redim the output array to accept maximum possible 
  For i = 1 To UBound(arr1)
    For Each El In arrCond
        If InStr(arr1(i, 8), El) > 0 Then
            k = k + 1
            For j = 1 To lastCol
                arr3(j, k) = arr1(i, j) 'fill the values in the output array
            Next j
            Exit For 'exits the loop to save time...
        End If
    Next
  Next i
  'Keep only the elements having values:
  ReDim Preserve arr3(1 To lastCol, 1 To k)
  'Drop the array content at once:
  sh3.Range("A2").Resize(k, UBound(arr3)).Value = WorksheetFunction.Transpose(arr3)
End Sub
相关问题
最新问题