VBA实现多个txt文件导入到一个Excel不用sheet中

annnie安妮

将一个文件夹里面的多个txt文件，按照外部数据导入到Excel中




Sub 导入本地文件夹TXT文件()
路径全名 = ThisWorkbook.FullName
命令文件 = ThisWorkbook.Name
路径名称 = Left(路径全名, Len(路径全名) - Len(命令文件)) '取得命令文件所在路径
If Right(路径名称, 1) > "\" Then 路径名称 = 路径名称 + "\"
文件类型 = "*.txt"
Set s = CreateObject("Scripting.FileSystemObject") '为VBA创建文件系统
Set d = s.GetFolder(路径名称) '为VBA指定文件夹
Set f = d.Files '将文件夹中全部文件作为处理对象
For Each k In f '逐个文件处理
m = k.Name '提取文件名（短文件名）
If (LCase(Right(m, 3)) = "txt") Then '如果是txt文件，就打开它
文本长名 = 路径名称 + k.Name
Application.StatusBar = "正打开文件：" + k.Name '在状态栏提示处理进度
Workbooks.OpenText Filename:=文本长名
On Error GoTo 出错提示 '防止因文本文件名称过长，影响表单移动
ActiveSheet.Move Before:=ThisWorkbook.Sheets(1) '以移动代替导入
On Error GoTo 0
End If
Next k
Set f = Nothing
Set d = Nothing
Set s = Nothing
MsgBox "当前文件夹中TXT文件收集完毕！", vbOKOnly, "处理结果"
Exit Sub
出错提示:
MsgBox "移动表单出错！（TXT文件名可能太长了）"
ActiveWorkbook.Close False
Resume Next
End Sub


当前代码存在以下几个问题：
1、导入后无法自动保存
2、无法选择文件编码UTF-8
3、无法选择多个不同分割符号（默认分割符号为tab键和空格号，如果想要用冒号（：）分割无法实现）

蓝桥玄霜

文本的提取的例子：

gwjkkkkk

Option Explicit
Sub test()
    Dim strFileName$, strPath$, strResult$(), ar, br, y&, x&, n&, r&, c&, strTxt$
   
    DoApp False
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.txt")
   
    Do Until strFileName = ""
        strTxt = ReadFromTextFile(ThisWorkbook.Path & "\" & strFileName)
        ar = Split(strTxt, vbCrLf): r = 0: c = 0
        ReDim strResult(1 To UBound(ar) + 1, 1 To 10 ^ 3)
        For y = 0 To UBound(ar)
            If Len(ar(y)) Then
                br = Split(Replace(ar(y), "：", vbTab), vbTab)
                r = r + 1
                For x = 0 To UBound(br)
                    strResult(r, x + 1) = br(x)
                Next x
                If UBound(br) + 1 > c Then c = UBound(br) + 1
            End If
        Next y
        With Workbooks.Add
            With .Sheets(1).[A1].Resize(r, c)
                .Value = strResult
                .HorizontalAlignment = xlCenter
                .Borders.LineStyle = xlContinuous
                .EntireColumn.AutoFit
                .EntireRow.AutoFit
            End With
            .SaveAs strPath & Left(strFileName, InStrRev(strFileName, ".") - 1)
            .Close
        End With
        strFileName = Dir
    Loop

    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

请参考附件。。。

annnie安妮

蓝桥玄霜 发表于 2024-11-19 14:02
文本的提取的例子：

谢谢老师！学习了！

annnie安妮

gwjkkkkk 发表于 2024-11-19 19:41
Option Explicit
Sub test()
    Dim strFileName$, strPath$, strResult$(), ar, br, y&, x&, n&, r&, c ...

谢谢老师！辛苦了！