manbet网

 找回密码
 注册

QQ登录

只需一步,快速开始

查看: 193|回复: 3
打印 上一主题 下一主题

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

[复制链接]
跳转到指定楼层
1楼
发表于 2021-6-8 11:44 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
3学分
求大神帮忙修改一下,用以前的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

最佳答案
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



祝順心,南無阿彌陀佛!

测试.zip

231.7 KB, 下载次数: 6

最佳答案

查看完整内容

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 ...
分享到:  QQ好友和群QQ好友和群
收藏收藏2
2楼
发表于 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



祝順心,南無阿彌陀佛!

demo.rar

248.16 KB, 下载次数: 11

评分

参与人数 2学分 +4 收起 理由
王宪 + 2 学习了
beachum + 2 我和小伙伴都惊呆了

查看全部评分

3楼
查看详细资料  楼主| 发表于 2021-6-8 15:49 | 只看该作者
cutecpu 发表于 2021-6-8 11:44
Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

非常感谢您的帮助!!!
4楼
 楼主| 发表于 2021-6-8 15:51 | 只看该作者
cutecpu 发表于 2021-6-8 11:44
Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

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

评分

参与人数 1学分 +2 收起 理由
cutecpu + 2 有喔,有 3 學分喔。祝順心,南無阿彌陀佛.

查看全部评分

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|manbet ( )

GMT+8, 2021-6-24 00:21 , Processed in 0.124800 second(s), 7 queries , Gzip On, Redis On.

Powered by X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表