Can someone help me make this code shorter?

[StefanAgape]

Greetings to everybody,


Thank you in advance for taking the time to read my post.


Will say right from the start that this is my first experience with VBA. Will be grateful for any response, even the ones that will tell me to search, learn and get good. That being said I will try to describe what I want the code to do and will also post bellow how the code looks at the moment.


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.


I just know that once I copy paste the code some of you will have a laugh.

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

 

[NdNoviceHlp]

Hi StefanAgape and Welcome to the Board! You can load all of your search words in an array. HTH. Dave

Dim cell As Range, Cnt As Integer, SearchArr As Variant
SearchArr = Array("gmbh", "studio", "solution") '.etc
For Cnt = LBound(SearchArr) To UBound(SearchArr)
With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, SearchArr(Cnt)) > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
Next Cnt

 

[StefanAgape]

Hi StefanAgape and Welcome to the Board! You can load all of your search words in an array. HTH. Dave

Dim cell As Range, Cnt As Integer, SearchArr As Variant
SearchArr = Array("gmbh", "studio", "solution") '.etc
For Cnt = LBound(SearchArr) To UBound(SearchArr)
With Sheets(1)
    For Each cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
        If InStr(cell.Value, SearchArr(Cnt)) > 0 Then
        .Rows(cell.Row).Copy Destination:=Sheets(3).Rows(cell.Row)
       End If
    Next cell
End With
Next Cnt

Thank you very much! Have a nice week-end!

 

[NdNoviceHlp]

You are Welcome. Thanks for posting your outcome. Be safe. Dave