VBA调用fso读取TXT转化EXCEL

VBA：TXT转EXCEL

---

• EXCEL版本： 2016

• 适用TXT样式： 固定分隔符规范TXT数据源

• 效果：
  调用对话框选择打开TXT，设置TXT分割符，将转化文件保存到TXT文件同一目录下。如下图：
  

• 关于批量txt转化EXCEL：
  可以结合Dir语句，遍历选定目下txt文件，再逐个转化成EXCEL文件。调用文件对话框选择目录语句如下：

Sub select_file_directory()
On Error Resume Next
Dim dig As Object
Set dig = Application.FileDialog(msoFileDialogFolderPicker)
With dig
	'从d盘下开始选择，也可以选择其他盘符。
	.InitialFileName = "d:\"
	.Show
	'文件目录
	file_directory = .SelectedItems(1)
End With
Set dig = Nothing
On Error GoTo 0
End Sub

• 转化代码如下：（感兴趣的朋友可以直接复制使用）

Sub txt_to_excel()
'关闭屏幕更新
Application.ScreenUpdating = False
Dim arr()
Dim brr
Dim sep, file_name As String
Dim file_path
Dim fso, f As Object
Dim col, row, i As Long

'设置txt分隔符
sep = "|"
Set fso = CreateObject("scripting.filesystemobject")
'调用文件对话框选择txt文件
file_path = Application.GetOpenFilename("TXT文件,*txt", 1, "请选择目标txt文件~")
If file_path = False Then MsgBox "您已经取消选择文件，点击结束程序~": End
file_name = Split(file_path, "\")(UBound(Split(file_path, "\")))
file_name = Split(file_name, ".")(0)
'从文件路径中截取txt文件名字，用于保存excel命名
Debug.Print file_name	

'如果不存在，怎创建该文件。第三个参数设置true。第二个参数，1是只读，2是写入，3是追加写入
Set f = fso.opentextfile(file_path, 1, True)
'如果文件指针位于 TextStream 文件末，则返回 True；否则如果不为只读则返回 False，只能以只读方式打开，不然会报错。
If f.atendofstream = False Then
    row = 1
    brr = Split(f.readline, sep)
    'txt数据一共有col列
    col = UBound(brr) + 1
    '动态数组只能修改最后一维，数组的第一位“行”固定了，只能到列上扩充，实际还是行坐标，这里还是定义变量row表示数组列。
    ReDim Preserve arr(1 To col, 1 To row)
    For i = 1 To col
    	'分割txt行，赋值到数组
        arr(i, row) = brr(i - 1)
    Next
End If
Do While f.atendofstream = False
    row = row + 1
    brr = Split(f.readline, sep)
    ReDim Preserve arr(1 To col, 1 To row)
    For i = 1 To col
        arr(i, row) = brr(i - 1)
    Next
Loop
'关闭txt对象
f.Close

'新建工作簿，保存txt内容
Set wb = Workbooks.Add
With ActiveSheet
	'转置数组，写入到单元格中。
    [a1].Resize(UBound(arr, 2), UBound(arr, 1)) = Application.WorksheetFunction.Transpose(arr)
End With
'保存工作簿
wb.SaveAs ThisWorkbook.path & "\" & file_name & ".xlsx"
'关闭工作簿
wb.Close True
'恢复屏幕更新
Application.ScreenUpdating = True
MsgBox "Convert successfully!"
End Sub