使用VBA将Excel文件展平为新文件夹

Question

我目前有以下代码。目前，此代码将循环遍历excel文件的文件夹，并将打开它们然后将它们保存在该文件夹中，但我无法获取代码，然后将这些文件展平，然后将它们放入另一个文件夹中。有什么建议吗？

Sub ALoopFile()

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.PrintCommunication = False

Dim MyFolder As String
Dim MyFile As String
Dim SendTo As String
Dim SendFile As String
Dim CurrentWB As Workbook 'Workbook Stores Workbook

MyFolder = "Y:\Dropbox (Efficiency3)\Monthly Projects\001 - AU"
MyFile = Dir(MyFolder & "\*.xls")

SendTo = "Y:\Dropbox (Efficiency3)\Monthly Projects\001 - AU\Flattened_Files"
SendFile = Dir(SendTo & "\*.xls")
Do While MyFile <> ""


Set CurrentWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=3) 'Sets CurrentWB = to that long name. This becomes the name of the workbook.
    CurrentWB.RunAutoMacros Which:=xlAutoOpen 'Enables Macros in Workbook
    CurrentWB.SaveAs Filename:=MyFolder & "\" & MyFile, FileFormat:=56
        For SheetNumber = 1 To CurrentWB.Sheets.Count 'Counts Worksheets in Workbook
            CurrentWB.Sheets(SheetNumber).Select 'Selects All Worksheets in Workbook
            If (CurrentWB.Sheets(SheetNumber).Name <> "What If") Then
                CurrentWB.Sheets(SheetNumber).Unprotect ("UMC626") 'Unprotects Workbook
                Cells.Select  'Selects Data in Workbook
                With CurrentWB.Sheets(SheetNumber).UsedRange
                    .Value = .Value
                End With
                CurrentWB.Sheets(SheetNumber).Protect Password:="UMC626", DrawingObjects:=True, Contents:=True, Scenarios:=True 'Protects Workbook
            End If
        Next SheetNumber 'Runs Through Iteration
        Sheets(1).Select
        Range("A1").Select 'Saves each workbook at the top of the page
        CurrentWB.SaveAs Filename:=SendTo & "\" & SendFile, FileFormat:=56, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False 'Saves Workbook in Flatten File Location
    CurrentWB.Close 'Closes Workbook

MyFile = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.PrintCommunication = True

End Sub

我使用ThisName = CurrentWB.Name

解决了这个问题

ALoopFile()

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.PrintCommunication = False

Dim MyFolder As String
Dim MyFile As String
Dim SendTo As String
Dim SendFile As String
Dim CurrentWB As Workbook 'Workbook Stores Workbook

MyFolder = "Y:\Dropbox (Efficiency3)\Monthly Projects\001 - AU\"
MyFile = Dir(MyFolder & "\*.xls")

SendTo = "Y:\Dropbox (Efficiency3)\Monthly Projects\001 - AU\Flattened_Files"
SendFile = Dir(SendTo & "\*.xls")
Do While MyFile <> ""


Set CurrentWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=3) 'Sets CurrentWB = to that long name. This becomes the name of the workbook.
    CurrentWB.RunAutoMacros Which:=xlAutoOpen 'Enables Macros in Workbook
    CurrentWB.SaveAs Filename:=MyFolder & "\" & MyFile, FileFormat:=56
    ThisName = CurrentWB.Name
        For SheetNumber = 1 To CurrentWB.Sheets.Count 'Counts Worksheets in Workbook
            CurrentWB.Sheets(SheetNumber).Select 'Selects All Worksheets in Workbook
            If (CurrentWB.Sheets(SheetNumber).Name <> "What If") Then
                CurrentWB.Sheets(SheetNumber).Unprotect ("UMC626") 'Unprotects Workbook
                Cells.Select  'Selects Data in Workbook
                With CurrentWB.Sheets(SheetNumber).UsedRange
                    .Value = .Value
                End With
                CurrentWB.Sheets(SheetNumber).Protect Password:="UMC626", DrawingObjects:=True, Contents:=True, Scenarios:=True 'Protects Workbook
            End If
        Next SheetNumber 'Runs Through Iteration
        Sheets(1).Select
        Range("A1").Select 'Saves each workbook at the top of the page
        CurrentWB.SaveAs Filename:=SendTo & "\" & ThisName
        CurrentWB.Close 'Closes Workbook

MyFile = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.PrintCommunication = True

End Sub