今天幫一位網友弄的，A列為文件名，B列為對應的文本文件內容。此代碼只適用于Excel2003及以下版本，因FileSearch方法被微軟閹割了。
Sub listfile()
”””””””””””””””””””””””
‘ 批量獲取指定目錄下所有文本文件名和內容 ‘
‘ ‘
”””””””””””””””””””””””
Dim fs, fso, fl
Dim mypath As String
Dim theSh As Object
Dim theFolder As Object
Dim strtmp As String
Application.ScreenUpdating = False
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject") ‘設置搜索路徑
Set theSh = CreateObject("shell.application")
Set theFolder = theSh.BrowseForFolder(0, "", 0, "")
If Not theFolder Is Nothing Then
mypath = theFolder.Items.Item.Path
End If
‘搜索開始
Set fs = Application.FileSearch
With fs
.NewSearch
.SearchSubFolders = True ‘搜索子目錄
.LookIn = mypath ‘搜索路徑
.FileName = "*.txt" ‘搜索文件類型為txt
If .Execute(SortBy:=msoSortByFileName) = 0 Then
C = .FoundFiles.Count ‘統計搜索到的文件個數
For i = 1 To C
strtemp = .FoundFiles(i) ‘設置臨時文件
n = InStrRev(strtemp, "\") ‘獲取文件路徑長度（不包括文件名）
‘獲取文件名及擴展名
strfilename = Replace(strtemp, Left(strtemp, n), "")
‘從A2單元格開始輸出格式為：文件名
Cells(i + 1, 1) = Left(strfilename, Len(strfilename) – 4)
Set fl = fso.opentextfile(strtemp, 1)
strtmp = fl.readall ‘讀取文本內容
Range("b" & i + 1) = strtmp ‘B2開始寫入內容
fl.Close
Next
Else
MsgBox "該文件夾里沒有符合要求的文件!"
End If
End With
Set fs = Nothing
Application.ScreenUpdating = True
End Sub
