[已解决]请教，各位高手我想用vba实现读取多个txt文件数据请问怎么实现？

qinshuai8507

我有多个txt文件，如何提取某行的某个数据到excel（数据是以逗号分隔的），然后读取的数据每个占一个单元格横向排列，下一个文件读取到下一行，请问怎么实现呢谢谢！

最佳答案

月排行榜 / 总排行榜

苏子龙

2017-6-12 15:57

1. Sub test()
   
2. Dim arr, rw%, i%, flm$
   
3. On Error Resume Next
   
4. Sheet1.UsedRange.ClearContents
   
5. flm = Dir(ThisWorkbook.Path & "/*.txt")
   
6. Do While flm <> ""
   
7.     rw = rw + 1
   
8.     Open ThisWorkbook.Path & "/" & flm For Input As #1
   
9.         arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
   
10.     Close #1
    
11.     With Sheet1
    
12.            .Cells(rw, 1) = Split(arr(1), ",")(0)
    
13.            .Cells(rw, 2) = Split(arr(6), ",")(2)
    
14.            .Cells(rw, 3) = Split(arr(6), ",")(6)
    
15.     End With
    
16.     flm = Dir
    
17. Loop
    
18. End Sub

复制代码

自己照着改改吧

跳转到最佳答案楼层

苏子龙

提问最好上传文件

qinshuai8507

苏子龙 发表于 2017-6-12 11:32
提问最好上传文件

已上传数据文件

苏子龙

1. Sub tt()
   
2. Dim arr, brr, i%, flm$
   
3. Dim Col%, Rw%
   
4. On Error Resume Next
   
5. flm = Dir(ThisWorkbook.Path & "/*.txt")
   
6. Do While flm <> ""
   
7.     Rw = Rw + 1
   
8.     Open flm For Input As #1
   
9.         arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
   
10.     Close #1
    
11.     For i = 0 To UBound(arr)
    
12.         brr = Split(arr(i), ",")
    
13.         If i = 0 Then
    
14.             Worksheets("sheet1").Cells(Rw, 1).Resize(1, UBound(brr) + 1) = brr
    
15.         Else
    
16.             Col = Worksheets("sheet1").Cells(Rw, Columns.Count).End(1).Column
    
17.             Worksheets("sheet1").Cells(Rw, Col + 1).Resize(1, UBound(brr) + 1) = brr
    
18.         End If
    
19.     Next
    
20.     flm = Dir
    
21. Loop
    
22. End Sub

复制代码

qinshuai8507

苏子龙 发表于 2017-6-12 13:27

你好大侠，我试了代码没运行没有提示错误，但是没有提取出数据来，运行后还是空白表格，请问是哪里的问题？

苏子龙

1. Sub ttt()
   
2. Dim arr, rw%, i%, flm$
   
3. 'On Error Resume Next
   
4. flm = Dir(ThisWorkbook.Path & "/*.txt")
   
5. Do While flm <> ""
   
6.     rw = rw + 1
   
7.     Open ThisWorkbook.Path & "/" & flm For Input As #1
   
8.         arr = Split(Replace(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf, ","), ",")
   
9.     Close #1
   
10.     For i = 0 To UBound(arr)
    
11.           Worksheets("sheet1").Cells(rw, 1 + i) = arr(i)
    
12.      Next
    
13.     flm = Dir
    
14. Loop
    
15. End Sub

复制代码

改，前面 Open ThisWorkbook.Path & "/" & flm For Input As #1 少了这个

qinshuai8507

苏子龙 发表于 2017-6-12 15:20
改，前面 Open ThisWorkbook.Path & "/" & flm For Input As #1 少了这个

大侠完美运行了，但是提取的数据是全部提取了，我想提取第2行第一个、第7行的第三个、第7行的第8个，提取这三个数据到指定位置还需要如何修改呢？

苏子龙

要不再开一帖，详细说明吧，太复杂，我也不会，让其他大神来处理吧

qinshuai8507

苏子龙 发表于 2017-6-12 15:38
要不再开一帖，详细说明吧，太复杂，我也不会，让其他大神来处理吧

数错了不好意思，是第7行第7个，大侠的代码已经很完美了，只要能把指定数据读出来就行，我自己再粘贴也行，再给指点下就ok了

苏子龙

1. Sub test()
   
2. Dim arr, rw%, i%, flm$
   
3. On Error Resume Next
   
4. Sheet1.UsedRange.ClearContents
   
5. flm = Dir(ThisWorkbook.Path & "/*.txt")
   
6. Do While flm <> ""
   
7.     rw = rw + 1
   
8.     Open ThisWorkbook.Path & "/" & flm For Input As #1
   
9.         arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
   
10.     Close #1
    
11.     With Sheet1
    
12.            .Cells(rw, 1) = Split(arr(1), ",")(0)
    
13.            .Cells(rw, 2) = Split(arr(6), ",")(2)
    
14.            .Cells(rw, 3) = Split(arr(6), ",")(6)
    
15.     End With
    
16.     flm = Dir
    
17. Loop
    
18. End Sub

复制代码

自己照着改改吧