修改VBA代码：提取含"CUSTOMER ID"单元格右侧相邻内容

I've adjusted your existing code to meet your requirement: it will now scan all Excel files in your target folder, locate cells containing "CUSTOMER ID", pull the customer name from the adjacent cell to the right of each match, and summarize everything (workbook name, worksheet name, customer name) into a new master worksheet.

Here's the updated code:

Sub SearchFolders()
    Dim fso As Object
    Dim fld As Object
    Dim strSearch As String
    Dim strPath As String
    Dim strFile As String
    Dim wOut As Worksheet
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim lRow As Long
    Dim rFound As Range
    Dim strFirstAddress As String
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    ' Update these values to match your needs
    strPath = "c:\MyFolder" ' Replace with your target folder path
    strSearch = "CUSTOMER ID" ' The text we're searching for
    
    Set wOut = Worksheets.Add
    lRow = 1
    
    ' Update header to reflect our new output
    With wOut
        .Cells(lRow, 1) = "Workbook"
        .Cells(lRow, 2) = "Worksheet"
        .Cells(lRow, 3) = "CUSTOMER ID Cell Address"
        .Cells(lRow, 4) = "Customer Name" ' New header for the extracted name
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.GetFolder(strPath)
        
        strFile = Dir(strPath & "\*.xls*")
        Do While strFile <> ""
            Set wbk = Workbooks.Open( _
                Filename:=strPath & "\" & strFile, _
                UpdateLinks:=0, _
                ReadOnly:=True, _
                AddToMRU:=False)
                
            For Each wks In wbk.Worksheets
                Set rFound = wks.UsedRange.Find(strSearch)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                End If
                
                Do
                    If rFound Is Nothing Then
                        Exit Do
                    Else
                        lRow = lRow + 1
                        .Cells(lRow, 1) = wbk.Name
                        .Cells(lRow, 2) = wks.Name
                        .Cells(lRow, 3) = rFound.Address
                        ' Pull value from the cell directly to the right of the found "CUSTOMER ID"
                        .Cells(lRow, 4) = rFound.Offset(0, 1).Value
                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)
                Loop While strFirstAddress <> rFound.Address
            Next wks
            
            wbk.Close (False)
            strFile = Dir
        Loop
        
        .Columns("A:D").EntireColumn.AutoFit
    End With
    
    MsgBox "Done! Results are in the new worksheet."
ExitHandler:
    Set wOut = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Exit Sub
    
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Key Changes Made: #

• Updated search text: Changed strSearch to "CUSTOMER ID" to target the correct cells.
• Revised headers: Renamed the 4th column header to "Customer Name" and adjusted the 3rd column to clarify it's the location of the "CUSTOMER ID" cell.
• Extracted adjacent cell value: Replaced rFound.Value with rFound.Offset(0, 1).Value to pull the value from the cell immediately to the right of each "CUSTOMER ID" match.
• Added clear user prompt: Modified the final message to tell users where to find the results.

Notes: #

• Make sure to update the strPath variable to point to your actual target folder.
• If a "CUSTOMER ID" cell has no value to its right, the code will return an empty string in the "Customer Name" column. You can add a check for this (e.g., If rFound.Offset(0,1).Value <> "" Then ...) if you want to skip empty entries.
• The code handles multiple "CUSTOMER ID" matches per worksheet, so it will capture all instances across all files.

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