从找到的文本向右返回单元格的值

Posted 2021-03-26

我正在尝试遍历一个文件夹，查找其中包含“CUSTOMER ID”字样的所有工作簿，然后从相邻的单元格复制（客户的名称在同一行的右边一个）。客户名称与工作簿文件名一起粘贴到主工作簿中。

我找到了以下代码，它返回我正在搜索的文本。

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

    'Change as desired
    strPath = "c:MyFolder"
    strSearch = "Specific text"

    Set wOut = Worksheets.Add
    lRow = 1
    With wOut
        .Cells(lRow, 1) = "Workbook"
        .Cells(lRow, 2) = "Worksheet"
        .Cells(lRow, 3) = "Cell"
        .Cells(lRow, 4) = "Text in Cell"
        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
                        .Cells(lRow, 4) = rFound.Value
                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)
                Loop While strFirstAddress <> rFound.Address
            Next

            wbk.Close (False)
            strFile = Dir
        Loop
        .Columns("A:D").EntireColumn.AutoFit
    End With
    MsgBox "Done"

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

答案

要从“特定文本”返回右侧单元格的值，请执行以下操作：

.Cells(lRow, 4) = rFound.Offset(0, 1).Value

另一答案

扩展@Tim Williams的正确建议......

找到看起来像的代码块：

.Cells(lRow, 1) = wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Value

并更改第四行，使其与他的代码匹配：

.Cells(lRow, 1) = wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Offset(0, 1).Value

这是一个方便的代码片段，可以在工具包中保留，但有时它太过沉重。一个示例是创建文件名和/或路径字符串的列表。如果不需要打开一个文件，那么打开所有文件会变得非常荒谬。当然，应该修改此工具以更好地满足各种要求，但对于许多场景来说，这是一个更好的选择。如果有人在那里搜索一千个文件的内容是一项艰巨的挑战，那么记录所有生成肯定命中的文件，并且您不需要打开任何已识别的文件或关心文件是否有文件或许多积极的点击...如果那是你，那么我建议使用的工具将胜过这里建议的工具称为..... Windows。

必须将Windows配置为搜索文件内容才能使其正常工作，并且设置位于两个不同的位置。一个是“搜索”窗口的“搜索”选项卡的“高级搜索”下拉菜单中的复选框。另一个位于“文件夹选项”窗口的“搜索”选项卡中。

使用OP的示例，生成包含字符串“CUSTOMER ID”的所有文件名和位置的列表。只需打开资源管理器，激活搜索框，然后键入：

内容：CUSTOMER ID

搜索完成后，突出显示要包含在列表中的结果，右键单击突出显示的区域，选择“复制为路径”。将新生成的列表粘贴到您选择的应用程序中。是的，真的很容易。