[已解决]请老师帮助：从多个文本文件中取值，生成需要样式的工作表。谢谢！！

tiger2008

从多个文本文件中取值，生成需要样式的工作表，请老师帮助提供VBA解决思路，谢谢！
附件已上传，简单说明如下：
1、文本文件有多个，名称不固定，均为txt格式，放在同一目录下。
2、工作表样式已经设定好，取值来自文本文件的表头信息和有账号行的信息。其中客户号、科目号、货币号对“账号”信息的二次拆分（以"."分割）。
3、生成工作表时，希望有种方式，1是可以按照原文本文件名称产生独自的工作表，2是产生一张汇总的工作表。

最佳答案

月排行榜 / 总排行榜

suye1010

2014-11-10 15:12

1. Const WINDOW_HANDLE = 0
   
2. Const OPTIONS = 0
   
3. Sub Consolidation()
   
4. Application.ScreenUpdating = False
   
5. Dim objShell, objFolder, FolderPath, FSO, FSOFolder, FSOFile, TxtFile
   
6. Dim RegExp As Object, NSH As Worksheet, SRNo As Long, TRNo As Long
   
7. Dim BH, BBMC, JGMC, BBYS, BMMC, BMH, BBRQ, HB
   
8. Dim TempStr, TempArr, ArrS(0 To 10000, 1 To 17), ArrT(0 To 50000, 1 To 17)
   
9. ArrT(0, 1) = "编号"
   
10. ArrT(0, 2) = "报表名称"
    
11. ArrT(0, 3) = "机构名称"
    
12. ArrT(0, 4) = "报表页数"
    
13. ArrT(0, 5) = "部门名称"
    
14. ArrT(0, 6) = "部门号"
    
15. ArrT(0, 7) = "报表日期"
    
16. ArrT(0, 8) = "货币"
    
17. ArrT(0, 9) = "账号"
    
18. ArrT(0, 10) = "客户号"
    
19. ArrT(0, 11) = "科目号"
    
20. ArrT(0, 12) = "货币号"
    
21. ArrT(0, 13) = "账号名称"
    
22. ArrT(0, 14) = "最后交易日"
    
23. ArrT(0, 15) = "余额"
    
24. ArrT(0, 16) = "月日均余额"
    
25. ArrT(0, 17) = "年日均余额"
    
26. Set objShell = CreateObject("Shell.Application")
    
27. Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "选择文本文件所在的文件夹", OPTIONS, "")
    
28. If objFolder Is Nothing Then Exit Sub
    
29. FolderPath = objFolder.Self.Path
    
30. Set FSO = CreateObject("Scripting.FileSystemObject")
    
31. Set FSOFolder = FSO.GetFolder(FolderPath)
    
32. Set RegExp = CreateObject("VBSCRIPT.REGEXP")
    
33. With RegExp
    
34.     .Global = False
    
35.     .Pattern = "\d{1,10}.\d{4}.\d{3}"
    
36. End With
    
37. For Each FSOFile In FSOFolder.Files
    
38. If FSOFile.Type = "Text Document" Then
    
39.     SRNo = 0
    
40.     ArrS(0, 1) = "编号"
    
41.     ArrS(0, 2) = "报表名称"
    
42.     ArrS(0, 3) = "机构名称"
    
43.     ArrS(0, 4) = "报表页数"
    
44.     ArrS(0, 5) = "部门名称"
    
45.     ArrS(0, 6) = "部门号"
    
46.     ArrS(0, 7) = "报表日期"
    
47.     ArrS(0, 8) = "货币"
    
48.     ArrS(0, 9) = "账号"
    
49.     ArrS(0, 10) = "客户号"
    
50.     ArrS(0, 11) = "科目号"
    
51.     ArrS(0, 12) = "货币号"
    
52.     ArrS(0, 13) = "账号名称"
    
53.     ArrS(0, 14) = "最后交易日"
    
54.     ArrS(0, 15) = "余额"
    
55.     ArrS(0, 16) = "月日均余额"
    
56.     ArrS(0, 17) = "年日均余额"
    
57. 
    
58.     Set TxtFile = FSOFile.OpenAsTextStream(1)
    
59.         Do While Not TxtFile.AtEndOfStream
    
60.             TempStr = TxtFile.readline
    
61.             If InStr(TempStr, "编号") Then
    
62.                 BH = Replace(Split(TempStr)(2), "编号:", "")
    
63.                 BBMC = Application.WorksheetFunction.Trim(TxtFile.readline)
    
64.             End If
    
65.             If InStr(TempStr, "机构名称") Then
    
66.                 JGMC = Replace(Split(TempStr)(2), "机构名称:", "")
    
67.                 BBYS = Mid(Split(TempStr, "第")(1), 1, 4)
    
68.             End If
    
69.             If InStr(TempStr, "部门名称") Then BMMC = Application.WorksheetFunction.Trim(Split(TempStr, "部门名称:")(1))
    
70.             If InStr(TempStr, "部门号") Then
    
71.                 BMH = Replace(Split(TempStr)(2), "部门号:", "")
    
72.                 BBRQ = Split(TempStr)(16)
    
73.                 HB = Split(TempStr, "货币:")(1)
    
74.             End If
    
75.             If RegExp.Test(TempStr) Then
    
76.                 SRNo = SRNo + 1
    
77.                 TRNo = TRNo + 1
    
78.                 TempArr = Split(Application.WorksheetFunction.Trim(TempStr))
    
79.                 ArrS(SRNo, 1) = BH: ArrT(TRNo, 1) = BH
    
80.                 ArrS(SRNo, 2) = BBMC: ArrT(TRNo, 2) = BBMC
    
81.                 ArrS(SRNo, 3) = JGMC: ArrT(TRNo, 3) = JGMC
    
82.                 ArrS(SRNo, 4) = BBYS: ArrT(TRNo, 4) = BBYS
    
83.                 ArrS(SRNo, 5) = BMMC: ArrT(TRNo, 5) = BMMC
    
84.                 ArrS(SRNo, 6) = BMH: ArrT(TRNo, 6) = BMH
    
85.                 ArrS(SRNo, 7) = BBRQ: ArrT(TRNo, 7) = BBRQ
    
86.                 ArrS(SRNo, 8) = HB: ArrT(TRNo, 8) = HB
    
87.                 ArrS(SRNo, 9) = TempArr(0): ArrT(TRNo, 9) = TempArr(0)
    
88.                 ArrS(SRNo, 10) = Split(TempArr(0), ".")(0): ArrT(TRNo, 10) = Split(TempArr(0), ".")(0)
    
89.                 ArrS(SRNo, 11) = Split(TempArr(0), ".")(1): ArrT(TRNo, 11) = Split(TempArr(0), ".")(1)
    
90.                 ArrS(SRNo, 12) = Split(TempArr(0), ".")(2): ArrT(TRNo, 12) = Split(TempArr(0), ".")(2)
    
91.                 ArrS(SRNo, 13) = TempArr(1): ArrT(TRNo, 13) = TempArr(1)
    
92.                 ArrS(SRNo, 14) = TempArr(2): ArrT(TRNo, 14) = TempArr(2)
    
93.                 ArrS(SRNo, 15) = TempArr(3): ArrT(TRNo, 15) = TempArr(3)
    
94.                 ArrS(SRNo, 16) = TempArr(4): ArrT(TRNo, 16) = TempArr(4)
    
95.                 ArrS(SRNo, 17) = TempArr(5): ArrT(TRNo, 17) = TempArr(5)
    
96.             End If
    
97.         Loop
    
98.     Set NSH = ThisWorkbook.Worksheets.Add
    
99.     NSH.Name = Replace(FSOFile.Name, ".txt", "")
    
100.     NSH.Cells.NumberFormat = "@"
     
101.     NSH.Range("A1").Resize(UBound(ArrS, 1) + 1, UBound(ArrS, 2)) = ArrS
     
102.     Erase ArrS
     
103.     TxtFile.Close
     
104. End If
     
105. Next
     
106. Set NSH = ThisWorkbook.Worksheets.Add
     
107. NSH.Name = "Total"
     
108. NSH.Cells.NumberFormat = "@"
     
109. NSH.Range("A1").Resize(UBound(ArrT, 1) + 1, UBound(ArrT, 2)) = ArrT
     
110. 
     
111. Set NSH = Nothing
     
112. Set RegExp = Nothing
     
113. Set FSOFolder = Nothing
     
114. Set FSO = Nothing
     
115. Set objFolder = Nothing
     
116. Set objShell = Nothing
     
117. Application.ScreenUpdating = True
     
118. End Sub
     

复制代码

生成表样式.zip (17.35 KB, 下载次数: 13)

2014-11-10 15:27 上传

点击文件名下载附件

跳转到最佳答案楼层

suye1010

1. Const WINDOW_HANDLE = 0
   
2. Const OPTIONS = 0
   
3. Sub Consolidation()
   
4. Application.ScreenUpdating = False
   
5. Dim objShell, objFolder, FolderPath, FSO, FSOFolder, FSOFile, TxtFile
   
6. Dim RegExp As Object, NSH As Worksheet, SRNo As Long, TRNo As Long
   
7. Dim BH, BBMC, JGMC, BBYS, BMMC, BMH, BBRQ, HB
   
8. Dim TempStr, TempArr, ArrS(0 To 10000, 1 To 17), ArrT(0 To 50000, 1 To 17)
   
9. ArrT(0, 1) = "编号"
   
10. ArrT(0, 2) = "报表名称"
    
11. ArrT(0, 3) = "机构名称"
    
12. ArrT(0, 4) = "报表页数"
    
13. ArrT(0, 5) = "部门名称"
    
14. ArrT(0, 6) = "部门号"
    
15. ArrT(0, 7) = "报表日期"
    
16. ArrT(0, 8) = "货币"
    
17. ArrT(0, 9) = "账号"
    
18. ArrT(0, 10) = "客户号"
    
19. ArrT(0, 11) = "科目号"
    
20. ArrT(0, 12) = "货币号"
    
21. ArrT(0, 13) = "账号名称"
    
22. ArrT(0, 14) = "最后交易日"
    
23. ArrT(0, 15) = "余额"
    
24. ArrT(0, 16) = "月日均余额"
    
25. ArrT(0, 17) = "年日均余额"
    
26. Set objShell = CreateObject("Shell.Application")
    
27. Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "选择文本文件所在的文件夹", OPTIONS, "")
    
28. If objFolder Is Nothing Then Exit Sub
    
29. FolderPath = objFolder.Self.Path
    
30. Set FSO = CreateObject("Scripting.FileSystemObject")
    
31. Set FSOFolder = FSO.GetFolder(FolderPath)
    
32. Set RegExp = CreateObject("VBSCRIPT.REGEXP")
    
33. With RegExp
    
34.     .Global = False
    
35.     .Pattern = "\d{1,10}.\d{4}.\d{3}"
    
36. End With
    
37. For Each FSOFile In FSOFolder.Files
    
38. If FSOFile.Type = "Text Document" Then
    
39.     SRNo = 0
    
40.     ArrS(0, 1) = "编号"
    
41.     ArrS(0, 2) = "报表名称"
    
42.     ArrS(0, 3) = "机构名称"
    
43.     ArrS(0, 4) = "报表页数"
    
44.     ArrS(0, 5) = "部门名称"
    
45.     ArrS(0, 6) = "部门号"
    
46.     ArrS(0, 7) = "报表日期"
    
47.     ArrS(0, 8) = "货币"
    
48.     ArrS(0, 9) = "账号"
    
49.     ArrS(0, 10) = "客户号"
    
50.     ArrS(0, 11) = "科目号"
    
51.     ArrS(0, 12) = "货币号"
    
52.     ArrS(0, 13) = "账号名称"
    
53.     ArrS(0, 14) = "最后交易日"
    
54.     ArrS(0, 15) = "余额"
    
55.     ArrS(0, 16) = "月日均余额"
    
56.     ArrS(0, 17) = "年日均余额"
    
57. 
    
58.     Set TxtFile = FSOFile.OpenAsTextStream(1)
    
59.         Do While Not TxtFile.AtEndOfStream
    
60.             TempStr = TxtFile.readline
    
61.             If InStr(TempStr, "编号") Then
    
62.                 BH = Replace(Split(TempStr)(2), "编号:", "")
    
63.                 BBMC = Application.WorksheetFunction.Trim(TxtFile.readline)
    
64.             End If
    
65.             If InStr(TempStr, "机构名称") Then
    
66.                 JGMC = Replace(Split(TempStr)(2), "机构名称:", "")
    
67.                 BBYS = Mid(Split(TempStr, "第")(1), 1, 4)
    
68.             End If
    
69.             If InStr(TempStr, "部门名称") Then BMMC = Application.WorksheetFunction.Trim(Split(TempStr, "部门名称:")(1))
    
70.             If InStr(TempStr, "部门号") Then
    
71.                 BMH = Replace(Split(TempStr)(2), "部门号:", "")
    
72.                 BBRQ = Split(TempStr)(16)
    
73.                 HB = Split(TempStr, "货币:")(1)
    
74.             End If
    
75.             If RegExp.Test(TempStr) Then
    
76.                 SRNo = SRNo + 1
    
77.                 TRNo = TRNo + 1
    
78.                 TempArr = Split(Application.WorksheetFunction.Trim(TempStr))
    
79.                 ArrS(SRNo, 1) = BH: ArrT(TRNo, 1) = BH
    
80.                 ArrS(SRNo, 2) = BBMC: ArrT(TRNo, 2) = BBMC
    
81.                 ArrS(SRNo, 3) = JGMC: ArrT(TRNo, 3) = JGMC
    
82.                 ArrS(SRNo, 4) = BBYS: ArrT(TRNo, 4) = BBYS
    
83.                 ArrS(SRNo, 5) = BMMC: ArrT(TRNo, 5) = BMMC
    
84.                 ArrS(SRNo, 6) = BMH: ArrT(TRNo, 6) = BMH
    
85.                 ArrS(SRNo, 7) = BBRQ: ArrT(TRNo, 7) = BBRQ
    
86.                 ArrS(SRNo, 8) = HB: ArrT(TRNo, 8) = HB
    
87.                 ArrS(SRNo, 9) = TempArr(0): ArrT(TRNo, 9) = TempArr(0)
    
88.                 ArrS(SRNo, 10) = Split(TempArr(0), ".")(0): ArrT(TRNo, 10) = Split(TempArr(0), ".")(0)
    
89.                 ArrS(SRNo, 11) = Split(TempArr(0), ".")(1): ArrT(TRNo, 11) = Split(TempArr(0), ".")(1)
    
90.                 ArrS(SRNo, 12) = Split(TempArr(0), ".")(2): ArrT(TRNo, 12) = Split(TempArr(0), ".")(2)
    
91.                 ArrS(SRNo, 13) = TempArr(1): ArrT(TRNo, 13) = TempArr(1)
    
92.                 ArrS(SRNo, 14) = TempArr(2): ArrT(TRNo, 14) = TempArr(2)
    
93.                 ArrS(SRNo, 15) = TempArr(3): ArrT(TRNo, 15) = TempArr(3)
    
94.                 ArrS(SRNo, 16) = TempArr(4): ArrT(TRNo, 16) = TempArr(4)
    
95.                 ArrS(SRNo, 17) = TempArr(5): ArrT(TRNo, 17) = TempArr(5)
    
96.             End If
    
97.         Loop
    
98.     Set NSH = ThisWorkbook.Worksheets.Add
    
99.     NSH.Name = Replace(FSOFile.Name, ".txt", "")
    
100.     NSH.Cells.NumberFormat = "@"
     
101.     NSH.Range("A1").Resize(UBound(ArrS, 1) + 1, UBound(ArrS, 2)) = ArrS
     
102.     Erase ArrS
     
103.     TxtFile.Close
     
104. End If
     
105. Next
     
106. Set NSH = ThisWorkbook.Worksheets.Add
     
107. NSH.Name = "Total"
     
108. NSH.Cells.NumberFormat = "@"
     
109. NSH.Range("A1").Resize(UBound(ArrT, 1) + 1, UBound(ArrT, 2)) = ArrT
     
110. 
     
111. Set NSH = Nothing
     
112. Set RegExp = Nothing
     
113. Set FSOFolder = Nothing
     
114. Set FSO = Nothing
     
115. Set objFolder = Nothing
     
116. Set objShell = Nothing
     
117. Application.ScreenUpdating = True
     
118. End Sub
     

复制代码

生成表样式.zip (17.35 KB, 下载次数: 13)

2014-11-10 15:27 上传

点击文件名下载附件

Excel学徒123

suye1010 发表于 2014-11-10 15:12

部分地方可以用循环简化{:1012:}

tiger2008

suye1010 发表于 2014-11-10 15:12

非常感谢suye1010老师的帮助，老师费心啦，俺也要认真学习理解，谢谢！

tiger2008

suye1010 发表于 2014-11-10 15:12

报告老师，运行后只生成了表头，没有导入数据，可以看一下吗？另外感觉导入速度很慢，可以优化吗？谢谢！

tiger2008

tiger2008 发表于 2014-11-10 17:52
报告老师，运行后只生成了表头，没有导入数据，可以看一下吗？另外感觉导入速度很慢，可以优化吗？谢谢！ ...

把这句  If FSOFile.Type = "Text Document" Then
改成  If FSOFile.Type = "文本文档" Then  就行了。
谢谢老师！