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。

这是循环文件夹中文件的一种方法（您必须在工具中添加对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

VBA如何将文件夹中的excel文件替换为Macro Enabled工作簿

2 个答案: