批量将Txt文件内容拆分成Excel文件

批量将Txt文件内容拆分成Excel文件

第1步： 新建一张Excel 表，并输入需要拆分Txt文件所在文件夹位置，以及拆分后数据保存Excel的路径信息，并保存名为"拆分.xlsm"格式

第2步：创建文件夹，以及保存Txt文件内容的Excel表格"test.xlsx"

第3步： 编写测试用例txt文件内容，将其拆分为6行4列数据

通州区 通州北关 2021年3月15日 3月
通州区 通州北关 2021年3月15日 3月
通州区 梨园 2021年3月16日 3月
通州区 通州北关 2021年3月16日 3月
通州区 次渠南 2021年3月16日 3月
通州区 通州北关 2021年3月16日 3月

第4步：编写宏，用于拆分数据

Sub splitTxt_Click()

  '获取存放结果的文件路径
  Dim resultPath As String
  resultPath = ThisWorkbook.Sheets(1).Range("c2")  '存放数据文件路径所在列
  '获取txt文件所在文件夹的集合
  arr = ThisWorkbook.Sheets(1).Range("B2:B" & ThisWorkbook.Sheets(1).UsedRange.Rows.Count)
  '遍历集合 获取文件夹
  For i = LBound(arr) To UBound(arr)
     '返回路径下的文件夹对象
    Dim file As Object, folder As Object
    Set Fso = CreateObject("scripting.FileSystemObject")
    Set folder = Fso.GetFolder(arr(i, 1))
    
    
     For Each file In folder.Files '遍历文件
       '判断文件是否为txt文件
       If FileSearch(file.Name) Then
           '转化txt为excel
           Call splitTxt(file.Path, resultPath)
       End If
    Next
  Next
  
End Sub


Private Function splitTxt(filePath As String, resultPath As String)
    '打开保存结果的文件
    Dim resultbook As Workbook
    Dim maxLine As Integer, row As Integer
    Set resultbook = Workbooks.Open(resultPath)
    maxLine = resultbook.Sheets(1).UsedRange.Rows.Count
    Debug.Print maxLine
    Dim ts As ADODB.Stream
    Set ts = New ADODB.Stream
    ts.Type = adTypeText
    ts.Charset = "Unicode"
    ts.LineSeparator = adLF
    ts.Open
       
    '文件装载
    ts.LoadFromFile (filePath)
     
    '开始写入的位置
    If maxLine <> 1 Then
     row = maxLine + 1
     Else: row = maxLine
    End If
    '读取txt文件
    Do While Not (ts.EOS)
        lineStr = ts.ReadText(adReadLine)
        '截取第一列
        resultbook.Sheets(1).Cells(row, 1) = Trim(Mid(lineStr, 1, InStr(lineStr, "   ")))
        lineStr = Trim(Mid(lineStr, InStr(lineStr, "   ")))
         '截取第四列
        resultbook.Sheets(1).Cells(row, 4) = Trim(Mid(lineStr, InStrRev(lineStr, "日") + 1))
        lineStr = Trim(Mid(lineStr, 1, InStr(lineStr, "日")))
        '截取第三列
        If InStr(lineStr, "年") <> 0 Then
           resultbook.Sheets(1).Cells(row, 3) = Trim(Mid(lineStr, InStr(lineStr, "年") - 4, InStr(lineStr, "日")))
           lineStr = Trim(Mid(lineStr, 1, InStr(lineStr, "年") - 5))
        Else
           resultbook.Sheets(1).Cells(row, 3) = ""
        End If
        '截取第二列
        resultbook.Sheets(1).Cells(row, 2) = lineStr
        row = row + 1
    Loop
    resultbook.Save
    resultbook.Close
    
End Function

'判断文件是否为txt文件
Private Function FileSearch(fname As String) As Boolean
   
    If fname Like "*.txt" Then
      
      FileSearch = True
    Else
       FileSearch = False
    End If
End Function

第5步：点击"拆分.xlsm"里的开始按钮，数据就会进行拆分