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

问题描述

我有一个很大的包含订单信息的 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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"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,"indust") > 0 Then
        .Rows(cell.Row).copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
End Sub

解决方法

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

main.py

,

您可以使用数组：

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

,

请测试下一个代码。它使用数组，仅在内存中工作并且应该非常快。它不会复制所有行，而是复制 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