TXT批量转换XLS文件

Jerry6455

请老师帮忙把压缩包里的TXT文件批量的转换成EXCEL文件，用VBA的形势一键批量转换，谢谢了

我之前弄了，不好使，总出现问题。还求老师们帮忙。谢谢了。

wlmhit903

简单写的代码，没有优化，供参考

fzxba

1. Sub test2()
   
2.   Dim Conn As Object, Fso As Object, oFile As Object
   
3.   Dim ar() As String, br, cr, strFilename As String
   
4.   Dim i As Long, j As Long, k As Long, n As Byte
   
5.   Application.ScreenUpdating = False
   
6.   Set Fso = CreateObject("Scripting.FileSystemObject")
   
7.   Set Conn = CreateObject("ADODB.Connection")
   
8.   Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.FullName
   
9.   Cells.Clear
   
10.   For Each oFile In Fso.GetFolder(ThisWorkbook.Path).Files
    
11.     If InStr(LCase(oFile.Name), ".txt") > 0 Then
    
12.       n = FreeFile
    
13.       Open oFile For Input As #n
    
14.       br = Split(StrConv(InputB(LOF(n), #n), vbUnicode), vbCrLf)
    
15.       Close #n
    
16.       k = 0
    
17.       ReDim ar(UBound(br), UBound(Split(br(0), vbTab)))
    
18.       For i = LBound(br) To UBound(br)
    
19.         If Len(Replace(br(i), Chr(9), vbNullString)) Then
    
20.           cr = Split(br(i), vbTab)
    
21.           For j = LBound(cr) To UBound(cr)
    
22.             ar(k, j) = cr(j)
    
23.           Next
    
24.           k = k + 1
    
25.         End If
    
26.       Next
    
27.       Range("A1").Resize(k, UBound(ar, 2) + 1) = ar
    
28.       br = Split(oFile.Path, ".")
    
29.       br(UBound(br)) = "xlsx"
    
30.       strFilename = Join(br, ".")
    
31.       If Fso.FileExists(strFilename) Then Fso.DeleteFile strFilename
    
32.       Conn.Execute "SELECT * INTO [" & strFilename & "].[Sheet1] FROM [" & ActiveSheet.Name & "$]"
    
33.       Cells.Clear
    
34.     End If
    
35.   Next
    
36.   Conn.Close
    
37.   Set Conn = Nothing
    
38.   Set Fso = Nothing
    
39.   Application.ScreenUpdating = True
    
40.   Beep
    
41. End Sub

复制代码

fzxba

20221216.rar (839 Bytes, 下载次数: 7)

2022-12-16 19:00 上传

点击文件名下载附件