Fatal编程技术网
  • excel/
  • Excel 有人能帮我把代码缩短吗？

Excel 有人能帮我把代码缩短吗？

excel vba search

Excel 有人能帮我把代码缩短吗？,excel,vba,search,Excel,Vba,Search,我有一个相当大的excel，其中包含订单信息。 我的目标是在“客户名称列”（H:H）中根据关键字查找商业地址的订单，然后将找到值的行复制到新的工作表中 得到了一个关键字列表，但由于我不知道如何在VBA中使用它，我只有一个代码，只要我复制粘贴代码并编写一个新的值/要搜索的单词，它就会根据每个单词重复搜索。 一旦识别出一个关键字，整行将被复制到第3页。第1页包含原始数据，第2页包含每个单词的单词列表。我不知道如何运行一个代码，将它们包含在搜索中，而不必每次逐个写入 Sub Commercial()

我有一个相当大的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
从搜索词列表中构建一个模式。我假设它们位于第2页A列，从第1行开始

选项显式
次商业（）
Const COL=“H”
将wb设置为工作簿
将ws作为工作表、wsList作为工作表、wsTarget作为工作表
暗淡的iRow一样长，iLastRow一样长，iTargetRow一样长
Dim ar作为变体，sPattern作为字符串，cell作为范围
使用此工作簿
设置ws=.Sheets（“Sheet1”）
设置wsList=.Sheets（“Sheet2”）
设置wsTarget=.Sheets（“Sheet3”）
以
'将搜索词列表放入数组并创建
“类似模式的单词1 |单词2 |单词3”
iLastRow=wsList.Cells（Rows.Count，“A”）.End（xlUp）.Row
ar=工作表函数.Transpose（wsList.Range（“A1:A”&iLastRow.Value））
sPattern=连接（ar，“|”）
MsgBox“搜索：”&飞溅
'创建正则表达式
Dim Regex作为对象，Match作为对象
设置Regex=CreateObject（“vbscript.regexp”）
用正则表达式
.Global=False
.MultiLine=False
.IgnoreCase=True
.图案=飞溅
以
"扫描数据,
iTargetRow=2
iLastRow=ws.Cells（Rows.Count，COL）.End（xlUp）.Row
对于ws.Range中的每个单元格（COL和“2:”&COL和iLastRow）
"模式检验",
如果正则表达式测试（CStr（单元））则
cell.EntireRow.Copy wsTarget.Rows（iTargetRow）
iTargetRow=iTargetRow+1
如果结束
下一个
"完!
MsgBox iTargetRow-2&“已复制行”，vbInformation
端接头
您可以使用阵列：

Dim单元格作为范围
作为变体的模糊词
将索引设置为整数
文字=阵列（“股份有限公司”、“解决方案”等，“工业”）
附页（1）
对于.Range（“H2:H”和.Cells（.Rows.Count，“H”）.End（xlUp.Row）中的每个单元格
索引=LBound（单词）到UBound（单词）
如果InStr（Cell.Value，Words（Index））>0，则
.Rows（Cell.Row）.复制目标：=工作表（3）.行（Cell.Row）
如果结束
下一个
下一个
以
请测试下一个代码。它使用数组，只在内存中工作，速度应该非常快。它不会复制所有行，而是复制图纸（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
宏位于哪里？与订单信息在同一工作簿中？订单信息以CSV形式提供，我只需将整个信息放入保存宏模块的excel文件中。首先，您不需要对每个条件进行迭代。一切都可以在同一个独特的迭代中完成。那么，您确定需要将该行复制到另一张图纸的相同行号上吗？您不需要根据这些条件提取所有行并将它们逐个粘贴到另一个工作表中吗？@FaneDuru True。我确实需要一个接一个地粘贴它们，但由于我不知道如何粘贴，我只记录了一个宏，我将在最后运行，它将在该表中放置过滤器并删除空白，这不是最干净的解决方案，但总比没有好。我尝试过使用“And”u并转到下一次迭代，但事实上这是第一次使用VBA，因为我无法将搜索串在一起而不会出错。将继续在网上搜索和观看youtube教程。谢谢你的评论！我会尝试准备一段代码来解决你的问题，如果我理解正确的话。。。