VBA如何将文件夹中的excel文件替换为启用宏的工作簿

试图找出如何将选定文件夹中的所有excel文件保存为启用宏的工作簿。如果可能，我只想保存启用宏的工作簿，以替换文件夹中的所有excel文件。目前，我只有在一个文件夹中打开一个excel文件的代码——我不知道如何将打开的工作簿保存为启用宏的工作簿，更不用说在整个文件夹中循环了。这是我的代码，如果我使用if语句而不是do-while循环来打开一个文件，它可以在一个文件上工作。它表示do while循环中的file=dir存在错误：

Sub SaveAllAsMacroWkbks()


Dim wb As Workbook
Dim myPath As String
Dim myFile As String, macFile As String
Dim myExtension As String, macExt As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
  .Title = "Select A Target Folder"
  .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"
  macExt = "*.xlsxm"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
  macFile = Dir(myPath & macExt)
'Loop through each Excel file in folder
  Do While myFile <> ""
      Set wb = Workbooks.Open(Filename:=myPath & myFile)
      'wb.saveAs FileName:=macFile, FileFormat:=52
      'wb.Close SaveChanges:=True
   'Get next file name
      myFile = Dir
  Loop

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Sub-savellascrowkbks（）
将wb设置为工作簿
将myPath设置为字符串
将myFile设置为字符串，将macFile设置为字符串
Dim myExtension作为字符串，MacText作为字符串
Dim FldrPicker As FILE对话框
'优化宏速度
Application.ScreenUpdating=False
Application.EnableEvents=False
Application.Calculation=xlCalculationManual
'从用户检索目标文件夹路径
Set FldrPicker=Application.FileDialog（msoFileDialogFolderPicker）
用FldrPicker
.Title=“选择目标文件夹”
.AllowMultiSelect=False
如果.Show-1，则转到下一个代码
myPath=.SelectedItems（1）和“\”
以
"如果取消,
下一个代码：
myPath=myPath
如果myPath=”“，则转到重置设置
'目标文件扩展名（必须包含通配符“*”）
myExtension=“*.xls*”
macExt=“*.xlsxm”
'具有结束扩展名的目标路径
myFile=Dir（myPath&myExtension）
macFile=Dir（myPath和macExt）
'循环浏览文件夹中的每个Excel文件
当我的文件“”时执行此操作
设置wb=Workbooks.Open（文件名：=myPath&myFile）
'wb.saveAs文件名：=macFile，文件格式：=52
'wb.Close SaveChanges:=True
'获取下一个文件名
myFile=Dir
环
重置设置：
'重置宏优化设置
Application.EnableEvents=True
Application.Calculation=xlCalculationAutomatic
Application.ScreenUpdating=True
端接头

请注意，宏工作簿扩展名是.xlsm，而不是代码中的.xlsxm

下面是一种循环浏览文件夹中文件的方法（您必须在工具->引用中添加对Microsoft脚本运行时的引用）：

这将工作簿另存为：

Workbook.SaveAs Filename:="C:\Users\....\filename.xlsm",FileFormat:=xlOpenXM‌​LWorkbookMacroEnable‌​d, CreateBackup:=False

---

下面的代码应该可以帮助您完成任务

Sub SaveAllAsXLSM()
    ' 27 Oct 2017

    Dim FldrPicker As FileDialog
    Dim myPath As String
    Dim myFile As String, newFile As String
    Dim Fn() As String
    Dim i As Long
    Dim Wb As Workbook

    ' Optimize Macro Speed
    Application.ScreenUpdating = False
    ' You aren't making any changes that trigger calculations
    ' nor do you have event procedures in your VB Project
    ' Therefore these commands do nothing but to take their own time to execute
'    Application.EnableEvents = False
'    Application.Calculation = xlCalculationManual

    ' User selects Target Folder Path
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show Then myPath = .SelectedItems(1) & "\"
    End With

    If Len(myPath) Then
        myFile = Dir(myPath)
        Do While Len(myFile)
            Fn = Split(myFile, ".")
            i = UBound(Fn)
            If StrComp(Fn(i), "xlsx", vbTextCompare) = 0 Then
                myFile = myPath & myFile
                Debug.Print myFile
                Set Wb = Workbooks.Open(Filename:=myFile)
                Fn(i) = "xlsm"
                newFile = myPath & Join(Fn, ".")
                Debug.Print newFile
                Wb.SaveAs Filename:=newFile, FileFormat:=52
                Wb.Close SaveChanges:=False

                Do
                    ' let the hard disc catch up with the VBA code
                    DoEvents
                Loop While IsOpen(myFile)
                Kill myFile                 ' delete the original
            End If

            myFile = Dir
        Loop
    End If

    Application.ScreenUpdating = True
End Sub

Private Function IsOpen(Fn As String) As Boolean
    ' 27 Oct 2017

    Dim i As Integer

    With Workbooks
        For i = 1 To .Count
            If StrComp(Fn, .Item(i).FullName, vbTextCompare) = 0 Then
                IsOpen = True
                Exit For
            End If
        Next i
    End With
End Function

我认为你不能在PC和v.v上处理Mac文件。但是，如果可能的话，你可以轻松地修改我的代码。您可以对扩展名为xls的文件执行相同的操作

我对VBA和硬盘运行的不同速度有些怀疑。DoEvents的循环应该会减慢代码的速度。它肯定会减慢代码的执行速度，但我不确定

DoEvents

是否能按预期工作。如果没有，代码仍然会太快

Sub SaveAllAsXLSM()
    ' 27 Oct 2017

    Dim FldrPicker As FileDialog
    Dim myPath As String
    Dim myFile As String, newFile As String
    Dim Fn() As String
    Dim i As Long
    Dim Wb As Workbook

    ' Optimize Macro Speed
    Application.ScreenUpdating = False
    ' You aren't making any changes that trigger calculations
    ' nor do you have event procedures in your VB Project
    ' Therefore these commands do nothing but to take their own time to execute
'    Application.EnableEvents = False
'    Application.Calculation = xlCalculationManual

    ' User selects Target Folder Path
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show Then myPath = .SelectedItems(1) & "\"
    End With

    If Len(myPath) Then
        myFile = Dir(myPath)
        Do While Len(myFile)
            Fn = Split(myFile, ".")
            i = UBound(Fn)
            If StrComp(Fn(i), "xlsx", vbTextCompare) = 0 Then
                myFile = myPath & myFile
                Debug.Print myFile
                Set Wb = Workbooks.Open(Filename:=myFile)
                Fn(i) = "xlsm"
                newFile = myPath & Join(Fn, ".")
                Debug.Print newFile
                Wb.SaveAs Filename:=newFile, FileFormat:=52
                Wb.Close SaveChanges:=False

                Do
                    ' let the hard disc catch up with the VBA code
                    DoEvents
                Loop While IsOpen(myFile)
                Kill myFile                 ' delete the original
            End If

            myFile = Dir
        Loop
    End If

    Application.ScreenUpdating = True
End Sub

Private Function IsOpen(Fn As String) As Boolean
    ' 27 Oct 2017

    Dim i As Integer

    With Workbooks
        For i = 1 To .Count
            If StrComp(Fn, .Item(i).FullName, vbTextCompare) = 0 Then
                IsOpen = True
                Exit For
            End If
        Next i
    End With
End Function