首页 > Excel > 批量获取指定目录下文本文件内容VBA代码

批量获取指定目录下文本文件内容VBA代码

2009年12月24日

  今天帮一位网友弄的,A列为文件名,B列为对应的文本文件内容。此代码只适用于Excel2003及以下版本,因FileSearch方法被微软阉割了。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Sub listfile()
''''''''''''''''''''''''''''''''''''''''''''''
' 宏由 www.pootor.com 录制,时间: 2009-12-24 '
' 批量获取指定目录下所有文本文件名和内容     '
'                                            '
''''''''''''''''''''''''''''''''''''''''''''''
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
作者: 分类: Excel 标签: , ,
声明:本站遵循 署名-非商业性使用-相同方式共享 3.0 共享协议. 转载请注明转自 执子之手与子偕老
  1. 本文目前尚无任何评论.
  1. 本文目前尚无任何 trackbacks 和 pingbacks.