Sub XO()

Dim strPath As String strPath = ThisWorkbook.Path Call getExcelFile0(strPath) End Sub

Sub getExcelFile0(sFolderPath As String) On Error Resume Next Dim f As String Dim file() As String x = 2 wj = 2 k = 2  ReDim file(1) file(1) = sFolderPath & "\"

lj = sFolderPath 'Stop     f = Dir(file(1) & "*.xlsx")     '萬用字元*.*表示所有檔案，*.xlsx Excel檔案     Do Until f = ""                            Cells(2, x).Hyperlinks.Add Anchor:=Cells(2, x), Address:=file(i) & f, TextToDisplay:=f

              Temp = lj & "\" & f   '外部檔案路徑        Dim wb As Workbook        Set wb = GetObject(Temp)               

       For Each sh In wb.Worksheets    '陣列        sh.Select       sheetname = sh.Name        Cells(3, wj).Value = f        Cells(4, k).Value = sheetname                                findx = "*" & Cells(1, 1) & "*"                                With sh.Range("a1:z500")         '使用萬用字元查詢         h = 5         Set c = .Find(findx, LookIn:=xlValues)         If Not c Is Nothing Then             FirstAddress = c.Address             '在這裡寫根據第一個找到的單元格進行的操作             Do                             '在這裡寫對根據後續找到的單元格進行的操作                ' Debug.Print c.Row, c.Column                ' c.Font.Color = vbRed                 Set c = .FindNext(c)                 r = c.Row  '返回行                 cl = c.Column '返回列                 x1 = c.Address                  Cells(h, wj) = x1                                   h = h + 1                                     Cells(h, wj) = c.Value                  h = h + 1                 Loop While Not c Is Nothing And c.Address <> FirstAddress         End If     End With    ' wb.Close savechanges:=False                             wj = wj + 1        k = k + 1                Next                                                 x = x + 1         f = Dir     Loop    End Sub