从xlsx到txt。 任何提示如何加快这个子程序？

我有一个代码将电子表格的每个工作表转换为一个txt文件。

代码运行良好，但是考虑到大量的出口（abuot 90 txt文件），我想寻求如何加快这个代码的build议。

这是我的代码：

Sub xlsxTotxt() Dim i As Integer Dim directory As String Dim fname As String Dim xWs As Worksheet Dim xTextFile As String Dim rdate As String directory = ThisWorkbook.Sheets("Macro").Range("D576").Value rdate = ThisWorkbook.Sheets("Macro").Range("E47").Value i = 0 Application.ScreenUpdating = False Application.DisplayAlerts = False Do While ThisWorkbook.Sheets("Macro").Range("D577").Offset(i).Value <> "" fname = Sheets("Macro").Range("D577").Offset(i).Value Workbooks.Open (directory & fname) For Each xWs In Workbooks(fname).Worksheets xWs.Copy xTextFile = directory & rdate & " - " & xWs.name & ".txt" Application.ActiveWorkbook.SaveAs filename:=xTextFile, FileFormat:=xlText Application.ActiveWorkbook.Saved = True Application.ActiveWorkbook.Close Next Workbooks(fname).Close i = i + 1 Loop Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub 

在此先感谢您的帮助！

Answer 1

而不是复制每张表

• 保存此工作簿
• select每个工作表
• 将工作簿保存为文本 – 这只会将select工作表保存为文本
• 重新打开原始工作簿
• closures上一个文本文件

 Sub xlsxTotxt（）

    昏暗我作为整数
    昏暗的目录为string
    昏暗的fname作为string
    昏暗的xWs作为工作表
     Dim xTextFile As String
    昏暗rdate作为string
     Dim ThisFullName As String
     ThisFullName = ThisWorkbook.FullName
     ThisWorkbook.Save

     directory = ThisWorkbook.Sheets（“Macro”）。Range（“D576”）。value
     rdate = ThisWorkbook.Sheets（“Macro”）。Range（“E47”）。value
    我= 0
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     Do While ThisWorkbook.Sheets（“Macro”）。Range（“D577”）。Offset（i）.value“”
         fname = Sheets（“Macro”）。Range（“D577”）。Offset（i）.value
         Workbooks.Open（目录＆fname）
        对于工作簿（fname）.Worksheets中的每个xWs
             xWs.Select
             xTextFile =目录＆rdate＆“ - ”＆xWs.Name＆“.txt”
             ThisWorkbook.SaveAs文件名：= xTextFile，FileFormat：= xlText
        下一个
        我=我+ 1
    循环
     Application.Workbooks.Open ThisFullName
     ThisWorkbook.Close False
     Application.ScreenUpdating = True
     Application.DisplayAlerts = True

结束小组