时间戳

首页 > 解决方案 > 单元格匹配多个或字符串然后复制

excel - 单元格匹配多个或字符串然后复制

问题描述

我是初学者。

我希望宏在每列中部分匹配“别克”、“雪佛兰”或“庞蒂亚克”。如果有的话，每个列将只有一个匹配项。

我有其他范围和其他词要匹配，但如果可以让这段代码工作，我应该能够编写剩下的东西。

我不断收到一条错误消息：

编译错误：预期：Then 或 GoTo

我不知道如何解决这个问题。

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

标签： excelvba

解决方案

您可以这样做 - 删除重复项并将其放在单独的 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

推荐阅读