跨多个列搜索匹配

Question

目前我的Excel VBA脚本搜索J列在main.xlsm进行匹配，如果发现匹配反对vda.xlsx A列，它强调以红色文字。我如何获得它在main.xlsm中通过专栏J-L进行搜索？

Sub VDA_Update() 

Dim wshT As Worksheet 
    Dim wbk As Workbook 
    Dim wshS As Worksheet 
    Dim r As Long 
    Dim m As Long 
    Dim cel As Range 
    Application.ScreenUpdating = False 
    Set wshT = ThisWorkbook.Worksheets("Master") 
    On Error Resume Next 

    ' Check whether vda.xlsx is already open 
    Set wbk = Workbooks("vda.xlsx") 
     On Error GoTo 0 
     If wbk Is Nothing Then 
     ' If not, open it 
     Set wbk = Workbooks.Open("C:\Working\vda_test.xlsx") 
    End If 

    ' Set worksheet on vda.xlsx 
    Set wshS = wbk.Worksheets("imac01") 
    m = wshT.Cells(wshT.Rows.Count, 1).End(xlUp).Row 

    ' Loop though cells in column J on main.xlsm 
    For r = 1 To m 

     ' Can we find the value in column A of vda.xlsx? 

     Set cel = wshS.Columns(1).Find(What:="TEST\" + wshT.Cells(r, 10).Value, _ 
     LookAt:=xlWhole, MatchCase:=False) 

     If Not cel Is Nothing Then 

      MsgBox wshS.Cells(r, 1) 

      ' If we find a match, then change the text to red 
      wshT.Cells(r, 10).Font.ColorIndex = 3 

     End If 
    Next r 

    Application.ScreenUpdating = True 

End Sub 

Answer 1

我刚刚添加了一个for循环，迭代1到2列更高，处理你的逻辑。

Sub VDA_Update() 

Dim wshT As Worksheet 
    Dim wbk As Workbook 
    Dim wshS As Worksheet 
    Dim r As Long 
    Dim m As Long 
    Dim cel As Range 
    Application.ScreenUpdating = False 
    Set wshT = ThisWorkbook.Worksheets("Master") 
    On Error Resume Next 

    ' Check whether vda.xlsx is already open 
    Set wbk = Workbooks("vda.xlsx") 
    On Error GoTo 0 
    If wbk Is Nothing Then 
     ' If not, open it 
     Set wbk = Workbooks.Open("C:\Working\vda_test.xlsx") 
    End If 

    ' Set worksheet on vda.xlsx 
    Set wshS = wbk.Worksheets("imac01") 
    m = wshT.Cells(wshT.Rows.Count, 1).End(xlUp).Row 

    ' Loop though cells in column J on main.xlsm 
    For r = 1 To m 

     ' Can we find the value in column A of vda.xlsx? 

     Set cel = wshS.Columns(1).Find(What:="TEST\" + wshT.Cells(r, 10).Value, _ 
     LookAt:=xlWhole, MatchCase:=False) 

     for i = 1 to 2 'K and L columns, Column J=10 
      If Cel is Nothing then 
       Set cel = wshS.Columns(1).Find(What:="TEST\" + wshT.Cells(r, 10 + i).Value, _ 
       LookAt:=xlWhole, MatchCase:=False) 
      else 
       exit for 
      end if 
     next i 

     If Not cel Is Nothing Then 

      MsgBox wshS.Cells(r, 1) 

      ' If we find a match, then change the text to red 
      wshT.Cells(r, 10).Font.ColorIndex = 3 

     End If 
    Next r 

    Application.ScreenUpdating = True 

End Sub