☰

如何在许多工作簿中搜索字符串并复制行（如果为真）

tag-icon • tag-icon microsoft-excel microsoft-excel-2007 worksheet-function
如何在许多工作簿中搜索字符串并复制行（如果为真）

我需要为客户提供一份报告。

我的一个文件夹中有大约 50 个文件（Excel 2007 工作簿）。每个工作簿大约有一百行和十列。我需要搜索字符串（在已知列“c1:c100”）“客户名称”。如果搜索结果为真，则将整行（1:10 列）复制到我的新报告表中。

我尝试录制一个宏，但是对编码和如何使其全部可变感到困惑。

答案1

将此代码粘贴到 VBA 资源管理器中，并将第 4 行的路径更改为指向包含文件的文件夹（确保包含尾随斜杠）。

这将搜索所有行和列。如果搜索字符串的其他实例位于除 C 之外的其他列中，它也会返回这些实例。它可以修改为仅搜索单个列范围，但如果范围由于某种原因发生变化，它将不再起作用。

Sub SearchWB()
    Dim myDir As String, fn As String, ws As Worksheet, r As Range
    Dim a(), n As Long, x As Long, myTask As String, ff As String, temp
    myDir = "C:\test\" '<- change path to folder with files to search
    If Dir(myDir, 16) = "" Then
        MsgBox "No such folder path", 64, myDir
        Exit Sub
    End If
    myTask = InputBox("Enter Customer Name")
    If myTask = "" Then Exit Sub
    x = Columns.Count
    fn = Dir(myDir & "*.xls*")
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Do While fn <> ""
        With Workbooks.Open(myDir & fn, 0)
            For Each ws In .Worksheets
                Set r = ws.Cells.Find(myTask, , , 1)
                If Not r Is Nothing Then
                    ff = r.Address
                    Do
                        n = n + 1
                        temp = r.EntireRow.Value
                        ReDim Preserve temp(1 To 1, 1 To x)
                        ReDim Preserve a(1 To n)
                        a(n) = temp
                        Set r = ws.Cells.FindNext(r)
                    Loop While ff <> r.Address
                End If
            Next
            .Close False
        End With
        fn = Dir
    Loop
    With ThisWorkbook.Sheets(1).Rows(1)
        .CurrentRegion.ClearContents
        If n > 0 Then
            .Resize(n).Value = _
            Application.Transpose(Application.Transpose(a))
        Else
            MsgBox "Not found", , myTask
        End If
    End With
End Sub

注意：这是在 Excel 2010 上测试的，但在 2007 上应该可以正常运行。修改后的代码来自此来源。

相关内容