编写VBA代码：在另一工作簿列中查找指定单元格子串是否存在

Got it, here's a couple of VBA approaches to solve your problem—one simple for small datasets, and a faster version for larger sets. Both will check each value in Workbook1's F column to see if it exists as a substring in any cell of Workbook2's D column, then output the result in the adjacent G column of Workbook1.

Basic Method (Using Find) #

This is straightforward and easy to read, perfect if you don't have thousands of rows to process:

Sub CheckSubstringsBasic()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim cell As Range
    Dim searchValue As String
    Dim foundRange As Range
    
    ' Update these to match your actual workbook/sheet names
    Set wb1 = Workbooks("Workbook1.xlsx")
    Set wb2 = Workbooks("Workbook2.xlsx")
    Set ws1 = wb1.Sheets("Sheet1") ' Replace with your sheet name in Workbook1
    Set ws2 = wb2.Sheets("Sheet1") ' Replace with your sheet name in Workbook2
    
    ' Loop through each non-empty cell in Workbook1's F column (starts at row 2 for header)
    For Each cell In ws1.Range("F2:F" & ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row)
        searchValue = cell.Value
        
        If searchValue <> "" Then
            ' Look for the substring in Workbook2's D column (case-insensitive)
            Set foundRange = ws2.Columns("D").Find( _
                What:=searchValue, _
                LookIn:=xlValues, _
                LookAt:=xlPart, _
                MatchCase:=False _
            )
            
            ' Write result to adjacent G column
            cell.Offset(0, 1).Value = IIf(Not foundRange Is Nothing, "Found", "Not Found")
        Else
            cell.Offset(0, 1).Value = "" ' Leave empty if source cell is blank
        End If
    Next cell
    
    MsgBox "Substring check finished!", vbInformation
End Sub

Efficient Method (Using Arrays) #

If you're dealing with hundreds or thousands of rows, this method is way faster because it minimizes slow worksheet interactions by loading all data into memory first:

Sub CheckSubstringsEfficiently()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim fLastRow As Long, dLastRow As Long
    Dim dValues() As Variant
    Dim i As Long, j As Long
    Dim searchValue As String
    Dim found As Boolean
    
    ' Update these to match your actual files/sheets
    Set wb1 = Workbooks("Workbook1.xlsx")
    Set wb2 = Workbooks("Workbook2.xlsx")
    Set ws1 = wb1.Sheets("Sheet1")
    Set ws2 = wb2.Sheets("Sheet1")
    
    ' Get last row with data in both columns
    fLastRow = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
    dLastRow = ws2.Cells(ws2.Rows.Count, "D").End(xlUp).Row
    
    ' Load all values from Workbook2's D column into an array
    dValues = ws2.Range("D2:D" & dLastRow).Value ' Skip header row; change to D1 if no header
    
    ' Loop through each value in Workbook1's F column
    For i = 2 To fLastRow ' Start at row 2 for header; change to 1 if no header
        searchValue = ws1.Cells(i, "F").Value
        found = False
        
        If searchValue <> "" Then
            ' Check each entry in the D column array for the substring
            For j = 1 To UBound(dValues)
                ' Use vbBinaryCompare for case-sensitive search instead of vbTextCompare
                If InStr(1, dValues(j, 1), searchValue, vbTextCompare) > 0 Then
                    found = True
                    Exit For ' Stop checking once found
                End If
            Next j
            
            ' Write result to G column
            ws1.Cells(i, "G").Value = IIf(found, "Found", "Not Found")
        Else
            ws1.Cells(i, "G").Value = ""
        End If
    Next i
    
    MsgBox "Efficient substring check completed!", vbInformation
End Sub

Key Notes: #

• Adjust Names: Make sure to update the workbook filenames and sheet names to match your actual files.
• Header Rows: Both codes assume you have a header row (starting at row 2). If you don't, change the starting row from 2 to 1 in the loops.
• Case Sensitivity: For case-sensitive searches, replace vbTextCompare with vbBinaryCompare in the efficient method, or set MatchCase:=True in the basic method.
• Closed Workbooks: If your workbooks aren't open, add Workbooks.Open("C:\Full\Path\To\Your\File.xlsx") before setting the wb1/wb2 variables. Just remember to save/close them if needed after running the code.

内容的提问来源于stack exchange，提问作者Minishopaholic