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

Question

试图弄清楚如何将选定文件夹中的所有 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

Answer 1

下面的代码应该可以帮助你。

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 是否会按预期工作。如果没有，代码仍然会太快。

Answer 2

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

这是一种遍历文件夹中文件的方法（您必须在 Tools->References 中添加对 Microsoft Scripting Runtime 的引用）：

Dim fso As New FileSystemObject
Dim folder As folder
Dim file As file

Set folder = fso.GetFolder("C:\Users")

For Each file In folder.Files
   'do stuff
Next

这会将工作簿保存为：

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