[已解决]Excel VBA提取众多txt文件中中指定区间数据到exce

wsk0722

vba  提取txt文件中固定区域之间的数据到excel表格中，路径为  E:\机构持股
文件包含多个，举例：     300001.TXT        300002.TXT        300003.TXT


开始字段为：          基金机构持股】
截止日期：2016-03-31

结束字段：
截止日期：2015-12-31

最佳答案

月排行榜 / 总排行榜

grf1973

2016-5-3 14:36

1. Sub 显示选定文件夹文件()       '调用Windows文件浏览器打开文件
   
2.     Range("A:A").ClearContents '清除
   
3.     Dim fso, fl, fp, IsRead As Boolean
   
4.     Dim wb As Workbook
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     fp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path & ""
   
7.     Dim arr(1 To 10000, 1 To 1)
   
8.     For Each fl In fso.getfolder(fp).Files
   
9.         IsRead = False
   
10.         If InStr(UCase(fl.Name), "TXT") > 0 Then
    
11.             Open fl For Input As #1
    
12.             Do While Not EOF(1)
    
13.                 Line Input #1, x  '读入每行
    
14.                 If Trim(x) = "【基金机构持股】" Then IsRead = True
    
15.                 If Trim(x) = "截止日期：2015-12-31" Then Exit Do
    
16.                 If IsRead Then n = n + 1: arr(n, 1) = x
    
17.             Loop
    
18.             Close #1
    
19.        End If
    
20.     Next
    
21.     If n > 0 Then [a1].Resize(n, 1) = arr
    
22. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 显示选定文件夹文件()       '调用Windows文件浏览器打开文件
   
2.     Range("A:A").ClearContents '清除
   
3.     Dim fso, fl, fp, IsRead As Boolean
   
4.     Dim wb As Workbook
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     fp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path & ""
   
7.     Dim arr(1 To 10000, 1 To 1)
   
8.     For Each fl In fso.getfolder(fp).Files
   
9.         IsRead = False
   
10.         If InStr(UCase(fl.Name), "TXT") > 0 Then
    
11.             Open fl For Input As #1
    
12.             Do While Not EOF(1)
    
13.                 Line Input #1, x  '读入每行
    
14.                 If Trim(x) = "【基金机构持股】" Then IsRead = True
    
15.                 If Trim(x) = "截止日期：2015-12-31" Then Exit Do
    
16.                 If IsRead Then n = n + 1: arr(n, 1) = x
    
17.             Loop
    
18.             Close #1
    
19.        End If
    
20.     Next
    
21.     If n > 0 Then [a1].Resize(n, 1) = arr
    
22. End Sub
    

复制代码

wsk0722

grf1973 发表于 2016-5-3 14:36

感谢老师解答，顺便问一句，能否吧提取的数据     每一行的最前端    添加所在文本文件     的文件名  ？

grf1973

1. Sub 显示选定文件夹文件()       '调用Windows文件浏览器打开文件
   
2.     Range("A:A").ClearContents '清除
   
3.     Dim fso, fl, fp, IsRead As Boolean
   
4.     Dim wb As Workbook
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     fp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path & ""
   
7.     Dim arr(1 To 10000, 1 To 1)
   
8.     For Each fl In fso.getfolder(fp).Files
   
9.         IsRead = False
   
10.         If InStr(UCase(fl.Name), "TXT") > 0 Then
    
11.             Open fl For Input As #1
    
12.             Do While Not EOF(1)
    
13.                 Line Input #1, x  '读入每行
    
14.                 If Trim(x) = "【基金机构持股】" Then IsRead = True
    
15.                 If Trim(x) = "截止日期：2015-12-31" Then Exit Do
    
16.                 If IsRead Then
    
17.                     tmp = Left(Trim(x), 2)
    
18.                     If tmp <> "【基" And tmp <> "截止" And tmp <> "合 " And tmp <> "──" _
    
19.                        And tmp <> "机构" And tmp <> "" Then x = Left(fl.Name, Len(fl.Name) - 4) & "  " & x
    
20.                     n = n + 1: arr(n, 1) = x
    
21.                 End If
    
22.             Loop
    
23.             Close #1
    
24.        End If
    
25.     Next
    
26.     If n > 0 Then [a1].Resize(n, 1) = arr
    
27. End Sub
    

复制代码

通过一些关键词判断哪些内容前不加代码。

wsk0722

grf1973 发表于 2016-5-4 09:28
通过一些关键词判断哪些内容前不加代码。

我决定要学习vba，是您点燃了我心灵学习的这盏灯。心中的感谢无以言表，真心感谢您！

wsk0722

感谢，我要好好学习VBA