Cara mencari string di banyak buku kerja dan menyalin baris jika benar

Saya perlu menjalankan laporan untuk pelanggan.

Saya memiliki sekitar 50 file (buku kerja Excel 2007) di folder. Setiap buku kerja memiliki sekitar seratus baris dan sepuluh kolom. Saya perlu mencari string (dalam kolom yang dikenal 'c1: c100') "nama pelanggan". Jika pencarian ini positif, salin seluruh baris ini (1:10 kolom) ke lembar laporan baru saya.

Saya mencoba merekam makro, tetapi membuat kode saya menjadi bingung dan bagaimana membuat semuanya menjadi variabel.

Rekatkan kode ini ke dalam VBA Explorer dan ubah jalur pada baris 4 untuk menunjuk ke folder yang berisi file-file tersebut (pastikan untuk menyertakan garis miring)

Ini akan mencari semua baris dan kolom. Jika ada contoh lain dari string pencarian di kolom yang berbeda dari C, itu akan mengembalikannya juga. Itu dapat dimodifikasi untuk hanya mencari rentang kolom tunggal tetapi tidak akan berfungsi jika rentang berubah karena alasan tertentu.

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

Catatan: ini telah diuji pada Excel 2010, tetapi harus berjalan dengan baik pada 2007. Kode yang dimodifikasi dari ini sumber .