如何用vba批量把固定分隔符或者固定宽度的文本文档另存为excel文件?

2019年6月17日 作者：水星Excel
3,505 次浏览 暂无评论

在平时的工作中经常会遇到固定分隔符或固定宽度的文本文档，如下图所示：

如果遇到大量的如上图所示的文本文档，可以借助vba批量将其另存为excel文档。

方法一、批量读取文本文档，用数组逐行写入excel单元格中，然后另存为excel文件。

以下代码将批量将同一文件夹下的所有按照固定分隔符分隔的文本文档另存为xlsx格式的Excel文档：

'文本文档所在的路径
Public sPath As String
'固定的分隔符
Public sDelimiter As String
Const ForAppending = 8
Const ForReading = 1
Const ForWriting = 2
'以系统默认的方式打开文本文档
Const TristateUseDefault = -2
'以Unicode方式打开文本文档
Const TristateTrue = -1
'以ASCII方式打开文本文档
Const TristateFalse = 0
Sub QQ1722187970()
    Excel.Application.ScreenUpdating = False
    Excel.Application.Calculation = xlCalculationManual
    Excel.Application.DisplayAlerts = False
    sDelimiter = ","
    '获取文件或者文件夹的路径
    sPath = GetPath()
    If Len(sPath) Then
        EnuAllFiles (sPath)
        MsgBox "处理完成!!!"
    End If
    Excel.Application.ScreenUpdating = True
    Excel.Application.Calculation = xlCalculationAutomatic
    Excel.Application.DisplayAlerts = True
End Sub
Function GetPath() As String
    '声明一个FileDialog对象变量
    Dim oFD As FileDialog
'    '创建一个选择文件对话框
'    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    '创建一个选择文件夹对话框
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    '声明一个变量用来存储选择的文件名
    Dim vrtSelectedItem As Variant
    With oFD
        '允许选择多个文件
        .AllowMultiSelect = True
        '使用Show方法显示对话框，如果单击了确定按钮则返回-1。
        If .Show = -1 Then
            '遍历所有选择的文件
            For Each vrtSelectedItem In .SelectedItems
                '获取所有选择的文件的完整路径,用于各种操作
                GetPath = vrtSelectedItem
            Next
            '如果单击了取消按钮则返回0
        Else
        End If
    End With
    '释放对象变量
    Set oFD = Nothing
End Function
Sub EnuAllFiles(ByVal sPath As String, Optional bEnuSub As Boolean = False)
    '定义文件系统对象
    Dim oFso As Object
    Set oFso = CreateObject("Scripting.FileSystemObject")
    '定义文件夹对象
    Dim oFolder As Object
    Set oFolder = oFso.GetFolder(sPath)
    '定义文件对象
    Dim oFile As Object
    '如果指定的文件夹含有文件
    If oFolder.Files.Count Then
        For Each oFile In oFolder.Files
            With oFile
                '输出文件所在的盘符
                Dim sDrive As String
                sDrive = .Drive
                '输出文件的类型
                Dim sType As String
                sType = .Type
                '输出含后缀名的文件名称
                Dim sName As String
                sName = .Name
                '输出含文件名的完整路径
                Dim sFilePath As String
                sFilePath = .Path
                If sType Like "文本文档" And Not (sName Like "*~$*") Then
                    If VBA.FileLen(sFilePath) = 0 Then
                        '空白文本文档不打开，直接删除
                        VBA.Kill sFilePath
                    Else
                        '获取文件名称
                        sName = GetFileName(sName)
                        Dim oWB As Workbook
                        Set oWB = Excel.Workbooks.Add
                        Set oWK = oWB.Worksheets(1)
                        i = 1
                        '打开文本文档
                        Set oTextStream = oFso.OpenTextFile(sFilePath, ForReading)
                        With oTextStream
                            '逐行导入
                            Do Until .AtEndOfStream
                                '获取每行的文本内容
                                sContent = .ReadLine
                                '按照分隔符拆分
                                arr = Split(sContent, sDelimiter)
                                '填充数组
                                oWK.Cells(i, 1).Resize(1, 1 + UBound(arr)) = arr
                                i = i + 1
                            Loop
                        End With
                        '另存为xlsx文件
                        oWB.SaveAs sPath & "\" & sName & ".xlsx"
                        oWB.Close
                    End If
                End If
            End With
        Next
    '如果指定的文件夹不含有文件
    Else
    End If
    '如果要遍历子文件夹
    If bEnuSub = True Then
        '定义子文件夹集合对象
        Dim oSubFolders As Object
        Set oSubFolders = oFolder.SubFolders
        If oSubFolders.Count > 0 Then
            For Each oTempFolder In oSubFolders
                sTempPath = oTempFolder.Path
                Call EnuAllFiles(sTempPath, True)
            Next
        End If
        Set oSubFolders = Nothing
    End If
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oFso = Nothing
End Sub
Function GetFileName(ByVal sName As String)
    '获取纯文件名的自定义函数
    'QQ1722187970
    Dim sTemp As String
    sTemp = sName
    '判断后缀名分隔符.的位置
    iPos = Len(sTemp) - VBA.InStr(1, VBA.StrReverse(sTemp), ".")
    If iPos <> 0 Then
        sTemp = Mid(sTemp, 1, iPos)
    End If
    '判断路径分隔符\的位置
    iPos = VBA.InStr(1, sTemp, "\")
    If iPos <> 0 Then
        '反转后好取字符
        iPos = VBA.InStr(1, VBA.StrReverse(sTemp), "\")
        sTemp = Mid(VBA.StrReverse(sTemp), 1, iPos - 1)
        sTemp = VBA.StrReverse(sTemp)
    End If
    GetFileName = sTemp
End Function

该方法的优缺点如下：

1.适用于每个文本文档的行数不多的情况。

2.速度快。

3.但是导入的数据格式无法自动识别。

4.不能用于固定宽度的文本文档的导入

方法二、批量读取文本文档，逐行导入excel文档中，然后用分列功能将整列分列，另存为excel文档。

代码如下：

'文本文档所在的路径
Public sPath As String
'固定的分隔符
Public sDelimiter As String
Const ForAppending = 8
Const ForReading = 1
Const ForWriting = 2
'以系统默认的方式打开文本文档
Const TristateUseDefault = -2
'以Unicode方式打开文本文档
Const TristateTrue = -1
'以ASCII方式打开文本文档
Const TristateFalse = 0
Sub QQ1722187970()
    Excel.Application.ScreenUpdating = False
    Excel.Application.Calculation = xlCalculationManual
    Excel.Application.DisplayAlerts = False
    sDelimiter = ","
    '获取文件或者文件夹的路径
    sPath = GetPath()
    If Len(sPath) Then
        EnuAllFiles (sPath)
        MsgBox "处理完成!!!"
    End If
    Excel.Application.ScreenUpdating = True
    Excel.Application.Calculation = xlCalculationAutomatic
    Excel.Application.DisplayAlerts = True
End Sub
Function GetPath() As String
    '声明一个FileDialog对象变量
    Dim oFD As FileDialog
'    '创建一个选择文件对话框
'    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    '创建一个选择文件夹对话框
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    '声明一个变量用来存储选择的文件名
    Dim vrtSelectedItem As Variant
    With oFD
        '允许选择多个文件
        .AllowMultiSelect = True
        '使用Show方法显示对话框，如果单击了确定按钮则返回-1。
        If .Show = -1 Then
            '遍历所有选择的文件
            For Each vrtSelectedItem In .SelectedItems
                '获取所有选择的文件的完整路径,用于各种操作
                GetPath = vrtSelectedItem
            Next
            '如果单击了取消按钮则返回0
        Else
        End If
    End With
    '释放对象变量
    Set oFD = Nothing
End Function
Sub EnuAllFiles(ByVal sPath As String, Optional bEnuSub As Boolean = False)
    '定义文件系统对象
    Dim oFso As Object
    Set oFso = CreateObject("Scripting.FileSystemObject")
    '定义文件夹对象
    Dim oFolder As Object
    Set oFolder = oFso.GetFolder(sPath)
    '定义文件对象
    Dim oFile As Object
    '如果指定的文件夹含有文件
    If oFolder.Files.Count Then
        For Each oFile In oFolder.Files
            With oFile
                '输出文件所在的盘符
                Dim sDrive As String
                sDrive = .Drive
                '输出文件的类型
                Dim sType As String
                sType = .Type
                '输出含后缀名的文件名称
                Dim sName As String
                sName = .Name
                '输出含文件名的完整路径
                Dim sFilePath As String
                sFilePath = .Path
                If sType Like "文本文档" And Not (sName Like "*~$*") Then
                    If VBA.FileLen(sFilePath) = 0 Then
                        '空白文本文档不打开，直接删除
                        VBA.Kill sFilePath
                    Else
                        '获取文件名称
                        sName = GetFileName(sName)
                        Dim oWB As Workbook
                        Set oWB = Excel.Workbooks.Add
                        Dim oWK As Worksheet
                        Set oWK = oWB.Worksheets(1)
                        i = 1
                        '打开文本文档
                        Set oTextStream = oFso.OpenTextFile(sFilePath, ForReading)
                        With oTextStream
                            '逐行导入
                            Do Until .AtEndOfStream
                                '获取每行的文本内容
                                sContent = .ReadLine
                                oWK.Cells(i, 1) = sContent
                                i = i + 1
                            Loop
                            '批量分列
                            With oWK
                                .Range("a1").EntireColumn.TextToColumns Destination:=.Range("a1"), DataType:=xlDelimited, comma:=True
                                .Columns.AutoFit
                            End With
                        End With
                        '另存为xlsx文件
                        oWB.SaveAs sPath & "\" & sName & ".xlsx"
                        oWB.Close
                    End If
                End If
            End With
        Next
    '如果指定的文件夹不含有文件
    Else
    End If
    '如果要遍历子文件夹
    If bEnuSub = True Then
        '定义子文件夹集合对象
        Dim oSubFolders As Object
        Set oSubFolders = oFolder.SubFolders
        If oSubFolders.Count > 0 Then
            For Each oTempFolder In oSubFolders
                sTempPath = oTempFolder.Path
                Call EnuAllFiles(sTempPath, True)
            Next
        End If
        Set oSubFolders = Nothing
    End If
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oFso = Nothing
End Sub
Function GetFileName(ByVal sName As String)
    '获取纯文件名的自定义函数
    'QQ1722187970
    Dim sTemp As String
    sTemp = sName
    '判断后缀名分隔符.的位置
    iPos = Len(sTemp) - VBA.InStr(1, VBA.StrReverse(sTemp), ".")
    If iPos <> 0 Then
        sTemp = Mid(sTemp, 1, iPos)
    End If
    '判断路径分隔符\的位置
    iPos = VBA.InStr(1, sTemp, "\")
    If iPos <> 0 Then
        '反转后好取字符
        iPos = VBA.InStr(1, VBA.StrReverse(sTemp), "\")
        sTemp = Mid(VBA.StrReverse(sTemp), 1, iPos - 1)
        sTemp = VBA.StrReverse(sTemp)
    End If
    GetFileName = sTemp
End Function

该方法的优缺点如下：

1.适用于每个文本文档的行数不多的情况。

2.速度快。

3.导入的数据格式可以被excel自动转换。

方法三、直接用导入外部数据的方式导入文本文档，然后另存为excel文档。

代码如下：

'文本文档所在的路径
Public sPath As String
'固定的分隔符
Public sDelimiter As String
Const ForAppending = 8
Const ForReading = 1
Const ForWriting = 2
'以系统默认的方式打开文本文档
Const TristateUseDefault = -2
'以Unicode方式打开文本文档
Const TristateTrue = -1
'以ASCII方式打开文本文档
Const TristateFalse = 0
Sub QQ1722187970()
    Excel.Application.ScreenUpdating = False
    Excel.Application.Calculation = xlCalculationManual
    Excel.Application.DisplayAlerts = False
    sDelimiter = ","
    '获取文件或者文件夹的路径
    sPath = GetPath()
    If Len(sPath) Then
        EnuAllFiles (sPath)
        MsgBox "处理完成!!!"
    End If
    Excel.Application.ScreenUpdating = True
    Excel.Application.Calculation = xlCalculationAutomatic
    Excel.Application.DisplayAlerts = True
End Sub
Function GetPath() As String
    '声明一个FileDialog对象变量
    Dim oFD As FileDialog
'    '创建一个选择文件对话框
'    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    '创建一个选择文件夹对话框
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    '声明一个变量用来存储选择的文件名
    Dim vrtSelectedItem As Variant
    With oFD
        '允许选择多个文件
        .AllowMultiSelect = True
        '使用Show方法显示对话框，如果单击了确定按钮则返回-1。
        If .Show = -1 Then
            '遍历所有选择的文件
            For Each vrtSelectedItem In .SelectedItems
                '获取所有选择的文件的完整路径,用于各种操作
                GetPath = vrtSelectedItem
            Next
            '如果单击了取消按钮则返回0
        Else
        End If
    End With
    '释放对象变量
    Set oFD = Nothing
End Function
Sub EnuAllFiles(ByVal sPath As String, Optional bEnuSub As Boolean = False)
    '定义文件系统对象
    Dim oFso As Object
    Set oFso = CreateObject("Scripting.FileSystemObject")
    '定义文件夹对象
    Dim oFolder As Object
    Set oFolder = oFso.GetFolder(sPath)
    '定义文件对象
    Dim oFile As Object
    '如果指定的文件夹含有文件
    If oFolder.Files.Count Then
        For Each oFile In oFolder.Files
            With oFile
                '输出文件所在的盘符
                Dim sDrive As String
                sDrive = .Drive
                '输出文件的类型
                Dim sType As String
                sType = .Type
                '输出含后缀名的文件名称
                Dim sName As String
                sName = .Name
                '输出含文件名的完整路径
                Dim sFilePath As String
                sFilePath = .Path
                '如果文件是Word文件且不是隐藏文件
                If sType Like "文本文档" And Not (sName Like "*~$*") Then
                    If VBA.FileLen(sFilePath) = 0 Then
                        '空白文本文档不打开，直接删除
                        VBA.Kill sFilePath
                    Else
                        '获取文件名称
                        sName = GetFileName(sName)
                        Dim oWB As Workbook
                        Set oWB = Excel.Workbooks.Add
                        Dim oWK As Worksheet
                        Set oWK = oWB.Worksheets(1)
                        sText = "TEXT;" & sFilePath
                        Dim oQB As QueryTable
                        With oWK
                        Set oQB = oWK.QueryTables.Add(sText, .Range("a1"))
                            With oQB
                                .FieldNames = True
                                .RowNumbers = False
                                .FillAdjacentFormulas = False
                                .PreserveFormatting = True
                                .RefreshOnFileOpen = False
                                .RefreshStyle = xlOverwriteCells
                                .SavePassword = False
                                .SaveData = False
                                .AdjustColumnWidth = True
                                .RefreshPeriod = 0
                                .TextFilePromptOnRefresh = False
                                '指定是从第几行开始导入数据
                                .TextFileStartRow = 1
                                '设置文本的解析类型是以固定宽度还是以固定分隔符
                                .TextFileParseType = xlDelimited
                                '设置文本的限定符
                                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                                '设置是否将连续的分隔符视为一个
                                .TextFileConsecutiveDelimiter = False
                                '设置是否以Tab为分隔符
                                .TextFileTabDelimiter = False
                                '设置是否以分号为分隔符
                                .TextFileSemicolonDelimiter = False
                                '设置是否以逗号为分隔符
                                .TextFileCommaDelimiter = True
                                '设置是否以空格为分隔符
                                .TextFileSpaceDelimiter = False
                                '设置其它的分隔符
                                .TextFileOtherDelimiter = ""
'                                '每个列用的格式
''                                .TextFileColumnDataTypes = Array(1, 1, 1, 1)
'                                '当以固定宽度导入时，设置每个列指定的列宽
'                                .TextFileFixedColumnWidths = Array(3, 5, 31)
                                '把带负号-的文本当做数字
                                .TextFileTrailingMinusNumbers = True
                                '异步更新
                                .Refresh BackgroundQuery:=False
                                .MaintainConnection = False
                                '以下两句最关键，只有加这两句，才不会再更新
                                .WorkbookConnection.Delete
                                .Delete
                            End With
                        End With
                        '另存为xlsx文件
                        oWB.SaveAs sPath & "\" & sName & ".xlsx"
                        oWB.Close
                    End If
                End If
            End With
        Next
    '如果指定的文件夹不含有文件
    Else
    End If
    '如果要遍历子文件夹
    If bEnuSub = True Then
        '定义子文件夹集合对象
        Dim oSubFolders As Object
        Set oSubFolders = oFolder.SubFolders
        If oSubFolders.Count > 0 Then
            For Each oTempFolder In oSubFolders
                sTempPath = oTempFolder.Path
                Call EnuAllFiles(sTempPath, True)
            Next
        End If
        Set oSubFolders = Nothing
    End If
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oFso = Nothing
End Sub
Function GetFileName(ByVal sName As String)
    '获取纯文件名的自定义函数
    'QQ1722187970
    Dim sTemp As String
    sTemp = sName
    '判断后缀名分隔符.的位置
    iPos = Len(sTemp) - VBA.InStr(1, VBA.StrReverse(sTemp), ".")
    If iPos <> 0 Then
        sTemp = Mid(sTemp, 1, iPos)
    End If
    '判断路径分隔符\的位置
    iPos = VBA.InStr(1, sTemp, "\")
    If iPos <> 0 Then
        '反转后好取字符
        iPos = VBA.InStr(1, VBA.StrReverse(sTemp), "\")
        sTemp = Mid(VBA.StrReverse(sTemp), 1, iPos - 1)
        sTemp = VBA.StrReverse(sTemp)
    End If
    GetFileName = sTemp
End Function

本方法的优点是全程一气呵成，不需要打开文本文档，另外还可以选择是从第几行开始导入，速度也快。

四、总结

本文介绍了3种导入外部文本文档，并将其另存为excel文档的方法，各有优缺点，大家在平时的应用中可以根据自己的文档特点选择。

 

其它相关文章推荐：

分类 :  VBA , 文件、文件夹、目录
标签 :  , , , , , , , ,
       

声明: 本站文章均属原创，未经作者同意必须保留此段声明，且在文章页面明显位置给出原文链接，否则视为侵权。如果想要每天都收到本站的技术文章推送，可以微信搜索公众号：水星Excel或者Excel_Office关注。其它事宜请加QQ：1722187970 或微信号：xycgenius 联系。 

发表评论