Как искать строку во многих книгах и копировать строку, если это правда

Question

Мне нужно запустить отчет для клиента.

У меня есть около 50 файлов (книги Excel 2007) в папке. Каждая рабочая тетрадь содержит около ста строк и десять столбцов. Мне нужно найти строку (в известном столбце «c1:c100») "имя клиента". Если этот поиск положительный, скопируйте всю строку (1:10 столбцов) в мой новый отчетный лист.

Я попытался записать макрос, но сбил с толку мой код и как сделать все это переменным.

Answer 1

Вставьте этот код в VBA Explorer и измените путь в строке 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 году. Модифицированный код из этого источника.