txt文件批量导入xecel问题

cjh-01

要求：1.将同一文件下的n个(500左右)txt文件批量导入excel文件，这里以4个为例。
          2.A列为txt文件名称，B\C列为相应txt文件中的数据(先按";"分列，再按","分列后导入)。
          3.导入后如附件结果所示。
          4.要求用vba解决。
          望指点，谢谢了！

liulang0808

1. Sub 按钮1_Click()
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.    
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
7.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
   
8.         If InStr(f.Name, "txt") > 0 Then
   
9.             Open f For Input As #1
   
10.             s = StrConv(InputB(LOF(1), 1), vbUnicode)
    
11.             arr = Split(s, ";")
    
12.             x = UBound(arr)
    
13.             Close #1
    
14.             r = Cells(Rows.Count, 1).End(3).Row + 1
    
15.             Cells(r, 1).Resize(x + 1) = f.Name
    
16.             Cells(r, 2).Resize(x + 1) = arr
    
17.         End If
    
18.     Next f
    
19.     Columns(2).TextToColumns Destination:=Range("B1"), Comma:=True
    
20.     [c1] = "数据2"
    
21.     Application.DisplayAlerts = True
    
22.     Application.ScreenUpdating = True
    
23. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim shResult As Worksheet
   
5.     Dim strFilePath As String, strFileName As String
   
6.     Dim strText As String, strSplit() As String
   
7.     Dim rgFileName As Range, rgResult As Range, lngRows As Long
   
8.     Dim arrFileName As Variant, arrResult As Variant
   
9.    
   
10.     Set shResult = Sheets("结果")
    
11.     Set rgFileName = shResult.Range("A2")
    
12.     Set rgResult = shResult.Range("B2")
    
13.     shResult.UsedRange.ClearContents
    
14.     shResult.Range("A1:C1") = Array("txt文件名", "数据1", "数据2")
    
15.    
    
16.     strFilePath = ThisWorkbook.Path & ""
    
17.     strFileName = "*.txt"
    
18.     strFileName = Dir(strFilePath & strFileName)
    
19.     Do While strFileName <> ""
    
20.         strText = GetContentByTxt(strFilePath & strFileName)
    
21.         strSplit = Split(strText, ";")
    
22.         lngRows = UBound(strSplit) + 1
    
23.         rgFileName.Resize(lngRows, 1) = Replace(strFileName, ".txt", "")
    
24.         rgResult.Resize(lngRows, 1) = Application.WorksheetFunction.Transpose(strSplit)
    
25.         rgResult.Resize(lngRows, 1).TextToColumns Destination:=rgResult, DataType:=xlDelimited, Comma:=True
    
26.         Set rgFileName = rgFileName.Offset(lngRows, 0)
    
27.         Set rgResult = rgResult.Offset(lngRows, 0)
    
28.         strFileName = Dir()
    
29.     Loop
    
30.     MsgBox "OK"
    
31. End Sub
    
32. 
    
33. Function GetContentByTxt(strFilePathAndName As String) As String
    
34.     Dim objFS As Object, objTS As Object
    
35.     Set objFS = CreateObject("Scripting.FileSystemObject")
    
36.     Set objTS = objFS.OpenTextFile(strFilePathAndName)
    
37.     GetContentByTxt = objTS.ReadAll
    
38.     objTS.Close: Set objTS = Nothing
    
39.     Set objFS = Nothing
    
40. End Function

复制代码

lsdongjh

代码审核中

cjh-01

代码简洁好用，谢谢！