Cells match multiple or strings then copy

Question

I'm a beginner.

I want the macro to partial match "Buick", "Chevrolet", or "Pontiac" in each column. There will only be one match per Column, if any.

The matches in Column D "SheetJS" should be copied to Column AA in "Sheet1".
The matches in Column E "SheetJS" should be copied to Column AH in "Sheet1".
The matches in Column F ("SheetJS") should be copied to Column AL in "Sheet1".

I have other ranges and other words to match but if can get this code working, I should be able to code the remaining things.

I keep getting an error message:

Compile Error: Expected: Then or GoTo

I don't know how to fix this issue.

Sub Extract_Data_Buick2()
    For Each cell In Sheets("SheetJS").Range("D1:D200")
        matchrow = cell.Row

        If instr ("*Buick*", cell.value)> 0 Or_
           instr ("*Chevrolet*", cell.value)> 0 Or_
           instr ("*Pontiac*", cell.value)> 0 Or_ Then
            Sheets("Sheet1").Range("AA" & matchrow).Value = cell.Value

        End If
    Next

    For Each cell In Sheets("SheetJS").Range("E1:E200")
        matchrow = cell.Row

        If instr ("*Buick*", cell.value)> 0 Or_
           instr ("*Chevrolet*", cell.value)> 0 Or_
           instr ("*Pontiac*", cell.value)> 0 Or_ Then
            Sheets("Sheet1").Range("AH" & matchrow).Value = cell.Value

        End If
    Next

    For Each cell In Sheets("SheetJS").Range("F1:F200")
        matchrow = cell.Row

        If instr ("*Buick*", cell.value)> 0 Or_
           instr ("*Chevrolet*", cell.value)> 0 Or_
           instr ("*Pontiac*", cell.value)> 0 Or_ Then
            Sheets("Sheet1").Range("AL" & matchrow).Value = cell.Value

        End If
    Next
End Sub

The underscore should have a space before it, plus what apf2 notes below. And you don't need the "*" when using Instr() — Tim Williams, Jan 12 '20 at 03:41
@tim williams I made the changes but for some reason nothing happens. I don't get an error code anymore but it doesn't copy anything. — Janet Delgado, Jan 12 '20 at 05:13

score 1 · Answer 1 · answered Jan 12 '20 at 03:10

1

The underline at the end of each line is to tell VBA the instruction continues on the next line. "instr ("Pontiac", cell.value)> 0 Or_ Then" in your code is confusing the compiler.

Try removing the Or_ before "then"

answered Jan 12 '20 at 03:10

apf2

7
4

I made the changes and I no longer get any error messages but it doesn't work. It doesn't copy any cells from SheetJS to Sheet1. – Janet Delgado Jan 12 '20 at 05:14

Tim Williams · Answer 2 · 2020-01-12T05:35:57.117

1

You can do it like this - remove the duplication and place it in a separate Sub.

Sub Extract_Data_Buick2()

    CopyMatches Sheets("SheetJS").Range("D1:D200"), "AA"
    CopyMatches Sheets("SheetJS").Range("E1:E200"), "AH"
    CopyMatches Sheets("SheetJS").Range("F1:F200"), "AL"

End Sub

Sub CopyMatches(rng As Range, DestCol as string)
    Dim v, e, c As Range

    For Each c In rng.Cells
        v = c.Value
        For Each e In Array("Buick", "Chevrolet", "Pontiac")
            If Instr(v, e) > 0 Then
                Sheets("Sheet1").Range(DestCol & c.Row).Value = v
                Exit For  'stop checking for this cell
            End If
        Next e
    Next c
End Sub

edited Jan 12 '20 at 05:35

answered Jan 12 '20 at 03:55

Tim Williams

154,628
8
97
125

I tried your code but I received an error message "Run-Time error '438': Object doesn't support this property or method" Can we do this in one sub? I have excel 2007 and it only recognized Extracr_Data_Buick2() I couldn't test the second sub. Thanks! – Janet Delgado Jan 12 '20 at 04:41
Comment out your original `Extract_Data_Buick2` and paste in the two subs above. I did just fix a couple of typos there... – Tim Williams Jan 12 '20 at 05:32
! It works! The only issue is it doesn't start pasting values in AA, instead it pastes them in AH, then AL, then AP, etc. – Janet Delgado Jan 12 '20 at 06:24
It works the same way your posted code would work if you fixed the typos, so I'm not sure what you really wanted to do there... Maybe update the description in your question. – Tim Williams Jan 12 '20 at 07:55

Cells match multiple or strings then copy

2 Answers2