วิธีค้นหาสตริงในสมุดงานจำนวนมากและคัดลอกแถวหากเป็นจริง

ฉันต้องการเรียกใช้รายงานสำหรับลูกค้า

ฉันมีไฟล์ประมาณ 50 ไฟล์ (เวิร์กบุ๊ก Excel 2007) ในโฟลเดอร์ สมุดงานแต่ละเล่มมีประมาณหนึ่งร้อยแถวและสิบคอลัมน์ ฉันต้องการค้นหาสตริง (ในคอลัมน์ที่รู้จัก 'c1: c100') "ชื่อลูกค้า" หากการค้นหานี้เป็นค่าบวกให้คัดลอกทั้งแถวนี้ (1:10 คอลัมน์) ไปยังแผ่นรายงานใหม่ของฉัน

ฉันลองบันทึกมาโคร แต่ทำให้รหัสของฉันยุ่งเหยิงและทำให้มันแปรปรวนทั้งหมด

วางรหัสนี้ใน 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 แก้ไขรหัสจากแหล่งที่มานี้