Can someone help me make this code shorter?

Question

I have quite a big excel that contains orders information. My goal is to find in the "customer name column" (H:H) the orders that are for commercial addresses based on key words and then copy the rows, where the values are found, to a new sheet.

Got a list of key words but since I do not know how to make use of it in VBA, I just have a code that will repeat the search based on each word as long as I copy paste the code and write a new value/word to be searched for. Once a key word is identified, the whole row will be copied in sheet 3. Sheet 1 contains the raw data and sheet 2 contains the list of words for each I do not know how to run a code that will include them in the search without me writing them 1 by 1 each time.

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

Where is the macro located ? In the same workbook as the order information ? — CDP1802, Feb 13 '21 at 13:00
The oder information comes as CSV and I just take the whole info and put it in the excel file where I saved the macro module. — Agape Stefan, Feb 13 '21 at 13:02
Firstly, you do not need an iteration for each condition. Everything can be done in the same unique iteration. Then, are you sure that you need to copy the row on the same row number of the other sheet? Don't you need to extract all rows according to those conditions and paste them one after the other in the other sheet? — FaneDuru, Feb 13 '21 at 13:08
@FaneDuru True. I do need to paste them one after the other but since I had no idea how to do that I just recorded a macro that I will run at the end and it will put filters in that sheet and remove the blanks, not the most clean solution but better than nothing. I tried with "And" _ and GoTo Next Iteration but the fact that it is the first time working with VBA shows since I was not able to string together the searches without getting error. Will keep searching on the web and watching youtube tutorials. Thanks for the comment! — Agape Stefan, Feb 13 '21 at 13:28
I will try preparing a piece of code able to solve your problem, if I correctly understood it... — FaneDuru, Feb 13 '21 at 13:36
@FaneDuru thank you, but please only help me it if you have the time to do so, there is no rush and if you need more context/information from me, let me know. — Agape Stefan, Feb 13 '21 at 13:41
You received three answers. Please, test them and it is good to know that we here tick the code left side check box, in order to make it **accepted answer**. In this way, somebody else searching for a similar issue will know that the code works. Not necessarily to tick my answer code! Please, test them and check the one which better suits your need... — FaneDuru, Feb 13 '21 at 14:25

CDP1802 · Accepted Answer · 2021-02-13T14:59:10.063

Build a regular expression pattern from the list of search words. I have assumed these are in column A on sheet 2 starting at row 1.

Option Explicit

Sub Commercial()

    Const COL = "H"
  
    Dim wb As Workbook
    Dim ws As Worksheet, wsList As Worksheet, wsTarget As Worksheet
    Dim iRow As Long, iLastRow As Long, iTargetRow As Long
    Dim ar As Variant, sPattern As String, cell As Range

    With ThisWorkbook
        Set ws = .Sheets("Sheet1")
        Set wsList = .Sheets("Sheet2")
        Set wsTarget = .Sheets("Sheet3")
    End With
    
    ' put list of search words in an array and create
    ' pattern like word1|word2|word3
    iLastRow = wsList.Cells(Rows.Count, "A").End(xlUp).Row
    ar = WorksheetFunction.Transpose(wsList.Range("A1:A" & iLastRow).Value)
    sPattern = Join(ar, "|")
    MsgBox "Search : " & sPattern
       
    ' create regular expression
    Dim Regex As Object, Match As Object
    Set Regex = CreateObject("vbscript.regexp")

    With Regex
        .Global = False
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = sPattern
    End With
    
    ' scan the data
    iTargetRow = 2
    iLastRow = ws.Cells(Rows.Count, COL).End(xlUp).Row
    For Each cell In ws.Range(COL & "2:" & COL & iLastRow)
    
        ' test against pattern
        If Regex.test(CStr(cell)) Then
            cell.EntireRow.Copy wsTarget.Rows(iTargetRow)
            iTargetRow = iTargetRow + 1
        End If
    
    Next
       
    ' end
    MsgBox iTargetRow - 2 & " rows copied", vbInformation
    
End Sub

score 1 · Answer 2 · answered Feb 13 '21 at 13:42

You could use an array:

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

FaneDuru · Answer 3 · 2021-02-13T13:53:02.213

Test the next code, please. It uses arrays, works only in memory and should be very fast. It does not copy all the rows, it copies the Sheets(1) existing columns value:

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

Can someone help me make this code shorter?

3 Answers3