同一路径下的txt文档批量转换为excel文件

小旋旋

新手小白，想要快速将统一个路径下的多个txt文档都转化为excel文件，txt的数据内容要分列后粘贴到excel表的指定位置，麻烦大神们帮忙处理一下~~
样例数据和需要实现的效果见附件

gwjkkkkk

Option Explicit
Sub test()
    Dim strFileName$, strPath$, strTxtName$, strTxt$
    Dim vResult$(), ar, br, y&, r&
   
    DoApp False
   
    ReDim vResult(1 To 10 ^ 4, 1 To 6)

    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.txt")
    Do Until strFileName = ""
        strTxtName = Left(strFileName, InStrRev(strFileName, ".") - 1)
        strTxt = ReadFromTextFile(ThisWorkbook.Path & "\" & strFileName)
        ar = Split(strTxt, vbCr)
        For y = 0 To UBound(ar)
            br = Split(ar(y), ",")
            r = r + 1
            vResult(r, 1) = br(0): vResult(r, 3) = br(4)
            vResult(r, 4) = br(3): vResult(r, 6) = br(2)
            vResult(r, 5) = strTxtName
        Next y
        strFileName = Dir
    Loop
   
    [A1].CurrentRegion.Offset(1).ClearContents
    If r Then [A2].Resize(r, UBound(vResult, 2)) = vResult
   
    DoApp
    Beep
End Sub
Function DoApp(Optional b As Boolean = True)
    With Application
        .ScreenUpdating = b
        .DisplayAlerts = b
        .Calculation = -b * 30 - 4135
    End With
End Function
Function ReadFromTextFile$(ByVal strFullName$, Optional ByVal strCharSet$ = "UTF-8")
    With CreateObject("ADODB.Stream")
        .Type = 2
        .Mode = 3
        .Charset = strCharSet
        .Open
        .LoadFromFile strFullName
        ReadFromTextFile = .ReadText
        .Close
    End With
End Function

gwjkkkkk

请参考附件。。。

ykcbf1100

附件供参考。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()  '//2024.2.19,多个txt批量转换成excel
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     On Error Resume Next
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If f.Name Like "*.txt" Then
   
9.             fn = fso.GetBaseName(f)
   
10.             zrr = Split(ReadUTFText(f), Chr(13))
    
11.             ReDim brr(1 To 1000, 1 To 6)
    
12.             m = 0
    
13.             For i = 0 To UBound(zrr)
    
14.                 If zrr(i) <> Empty Then
    
15.                     s = WorksheetFunction.Trim(zrr(i))
    
16.                     b = Split(s, ",")
    
17.                     m = m + 1
    
18.                     brr(m, 1) = b(0)
    
19.                     brr(m, 3) = b(4)
    
20.                     brr(m, 4) = b(1)
    
21.                     brr(m, 5) = fn
    
22.                     brr(m, 6) = b(2)
    
23.                 End If
    
24.             Next
    
25.             Application.SheetsInNewWorkbook = 1
    
26.             Set wb = Workbooks.Add
    
27.             With wb.Sheets(1)
    
28.                 .Columns(4).NumberFormatLocal = "@"
    
29.                 .[a1:f1] = Array("中间号码", "省份", "省份代码", "唯一编码", "文件名称", "绑定时间")
    
30.                 .[a2].Resize(m, 6) = brr
    
31.                 With .[a1].Resize(m + 1, 6)
    
32.                     .Borders.LineStyle = 1
    
33.                     .HorizontalAlignment = xlCenter
    
34.                     .VerticalAlignment = xlCenter
    
35.                     .EntireColumn.AutoFit
    
36.                 End With
    
37.                 .SaveAs p & fn
    
38.                 .Close 1
    
39.             End With
    
40.         End If
    
41.     Next f
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "OK！"
    
44. End Sub
    

复制代码

小旋旋

ykcbf1100 发表于 2024-2-19 09:12
附件供参考。。。

十分感谢，一下就搞定了~\(≥▽≤)/~

3190496160

Sub 导入txt文件()
Dim s() As String, arr(), brr, i&, j&
ActiveSheet.[a1].CurrentRegion.Offset(1).ClearContents
ReDim arr(1 To 50000, 1 To 6)
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "*.txt")
Do While f <> ""
    Open lj & f For Input As #1
    s = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCr)
    Close #1
    For i = 0 To UBound(s)  '请确认文本文件最后一行为空行
        n = n + 1
        brr = Split(s(i), ",")
        arr(n, 1) = brr(0)
        arr(n, 3) = UBound(brr)
        arr(n, 4) = brr(1)
        arr(n, 5) = Split(f, ".")(0)
        arr(n, 6) = brr(2)
    Next i
f = Dir
Loop
Columns("D:D").NumberFormatLocal = "@"
[a2].Resize(n, 6) = arr
End Sub

3190496160

新建文件夹.rar (16.97 KB, 下载次数: 11)

2024-2-19 11:09 上传

点击文件名下载附件

fzxba

gwjkkkkk 发表于 2024-2-18 20:13
请参考附件。。。

gwjkkkkk 兄，vResult(r, 4) = br(3) 应是  vResult(r, 4) = br(1) ，瞧你粗心的，此贴回复你质量高……

gwjkkkkk

fzxba 发表于 2024-2-19 13:29
gwjkkkkk 兄，vResult(r, 4) = br(3) 应是  vResult(r, 4) = br(1) ，瞧你粗心的，此贴回复你质量高……

对的，fzxba兄，你是大师级的，很多代码都是抄你的，就是徒弟交作业不认真，哈哈