[已解决]txt文件批量转excel文件

beachum

求大神帮忙修改一下，用以前的vba代码始终出问题！有代码备注最好，方便学习！Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set fso = CreateObject("scripting.filesystemobject")
        For Each file In fso.getfolder(ThisWorkbook.Path).Files
           If file.Name Like "*.txt" Then
               Set mytext = fso.opentextfile(file.Path)
               mycontent = mytext.readall
               mytext.Close
               arr = Split(mycontent, vbCrLf)
               Set wb = Workbooks.Add
               wb.Sheets(1).[a1].Resize(UBound(arr, 1)) = arr
               wb.Sheets(1).[a1].CurrentRegion.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
                            FieldInfo:=Array(Array(0, 1), Array(5, 1), Array(10, 1), Array(17, 1), Array(23, 1), _
                            Array(28, 1), Array(31, 1), Array(36, 1), Array(41, 1), Array(48, 1), Array(50, 1)), _
                            TrailingMinusNumbers:=True
               ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & Split(file.Name, ".")(0) & ".xlsx"
               ActiveWindow.Close True
           End If
        Next file
    Application.ScreenUpdating =TRUE
    Application.DisplayAlerts =TRUE
End Sub

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-6-8 11:44

Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Set fso = CreateObject("scripting.filesystemobject")
   Set conn = CreateObject("adodb.connection")
   Set rs = CreateObject("adodb.recordset")
   Path = ThisWorkbook.Path & "\"
   conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='text;HDR=No';Data Source =" & Path

   For Each file In fso.getfolder(ThisWorkbook.Path).Files
      If Not file.Name Like "*.txt" Then GoTo 1
      Sql = "select * from " & file.Name
      rs.Open Sql, conn, 3, 3
      If rs.RecordCount <> 0 Then
          [a1:g5000].ClearContents
         [a1].CopyFromRecordset rs
         [a:a].TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Space:=True
      End If
      rs.Close
      NewFile = Path & Split(file.Name, ".")(0) & ".xlsx"
      ActiveWorkbook.SaveAs Filename:=NewFile, FileFormat:=xlOpenXMLWorkbook
1:
   Next
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub



祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Set fso = CreateObject("scripting.filesystemobject")
   Set conn = CreateObject("adodb.connection")
   Set rs = CreateObject("adodb.recordset")
   Path = ThisWorkbook.Path & "\"
   conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='text;HDR=No';Data Source =" & Path

   For Each file In fso.getfolder(ThisWorkbook.Path).Files
      If Not file.Name Like "*.txt" Then GoTo 1
      Sql = "select * from " & file.Name
      rs.Open Sql, conn, 3, 3
      If rs.RecordCount <> 0 Then
          [a1:g5000].ClearContents
         [a1].CopyFromRecordset rs
         [a:a].TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Space:=True
      End If
      rs.Close
      NewFile = Path & Split(file.Name, ".")(0) & ".xlsx"
      ActiveWorkbook.SaveAs Filename:=NewFile, FileFormat:=xlOpenXMLWorkbook
1:
   Next
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
End Sub



祝順心，南無阿彌陀佛！

beachum

cutecpu 发表于 2021-6-8 11:44
Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

非常感谢您的帮助！！！

beachum

cutecpu 发表于 2021-6-8 11:44
Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

我设置的是3个学分，怎么上面的记录是2个学分呢？

beachum

cutecpu 发表于 2021-6-8 11:44
Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

@cutecpu大神，我遇到一个问题，每次txt文件转换xlsx文件时，总是在第二个文件（sh#600004）开始有些文件转换后，就出现
数据本该在4千多行的地方结束，但后面在5千行开始又有日期列
出现的现象。因为这样的现象后面计算的数据非常不准，需麻烦
您帮忙看看，原因在哪！谢谢！

cutecpu

beachum 发表于 2021-7-9 16:14
@cutecpu大神，我遇到一个问题，每次txt文件转换xlsx文件时，总是在第二个文件（sh#600004）开始有些文件 ...

原來: [a1:g5000].ClearContents
修改: [a1:g50000].ClearContents


祝順心，南無阿彌陀佛！