Schleife durch mehrere Excel-Arbeitsblätter in einer Arbeitsmappe mit VBA

Question

Hier ist ein Stück Code, den ich geschrieben habe, um eine Formatierung Aufgabe auf verschiedenen Excel-Dateien in einem bestimmten Ordner zu tun. Das Problem ist jedoch nur auf dem ersten Arbeitsblatt aller Excel-Arbeitsmappen in diesem Ordner ausgeführt. Ich kann nicht alle einzelnen Arbeitsblätter aller Excel-Dateien durchlaufen. Bitte helfen Sie mir den Code zu bearbeiten. Dank

Sub LoopAllExcelFilesInFolder() 

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 
'SOURCE: www.TheSpreadsheetGuru.com 

Dim wb As Workbook 
Dim myPath As String 
Dim myFile As String 
Dim myExtension 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" 

'Target Path with Ending Extention 
    myFile = Dir(myPath & myExtension) 

'Loop through each Excel file in folder 
    Do While myFile <> "" 
    'Set variable equal to opened workbook 
     Set wb = Workbooks.Open(Filename:=myPath & myFile) 

    'Change the layout 
Application.PrintCommunication = False 
    With ActiveSheet.PageSetup 
     .PrintTitleRows = "" 
     .PrintTitleColumns = "" 
    End With 
    Application.PrintCommunication = True 
    ActiveSheet.PageSetup.PrintArea = "" 
    Application.PrintCommunication = False 
    With ActiveSheet.PageSetup 
     .LeftHeader = "" 
     .CenterHeader = "" 
     .RightHeader = "" 
     .LeftFooter = "" 
     .CenterFooter = "" 
     .RightFooter = "" 
     .LeftMargin = Application.InchesToPoints(0.7) 
     .RightMargin = Application.InchesToPoints(0.7) 
     .TopMargin = Application.InchesToPoints(0.75) 
     .BottomMargin = Application.InchesToPoints(0.75) 
     .HeaderMargin = Application.InchesToPoints(0.3) 
     .FooterMargin = Application.InchesToPoints(0.3) 
     .PrintHeadings = False 
     .PrintGridlines = False 
     .PrintComments = xlPrintNoComments 
     .PrintQuality = 600 
     .CenterHorizontally = False 
     .CenterVertically = False 
     .Orientation = xlLandscape 
     .Draft = False 
     .PaperSize = xlPaperLetter 
     .FirstPageNumber = xlAutomatic 
     .Order = xlDownThenOver 
     .BlackAndWhite = False 
     .Zoom = False 
     .FitToPagesWide = 1 
     .FitToPagesTall = False 
     .PrintErrors = xlPrintErrorsDisplayed 
     .OddAndEvenPagesHeaderFooter = False 
     .DifferentFirstPageHeaderFooter = False 
     .ScaleWithDocHeaderFooter = True 
     .AlignMarginsHeaderFooter = True 
     .EvenPage.LeftHeader.Text = "" 
     .EvenPage.CenterHeader.Text = "" 
     .EvenPage.RightHeader.Text = "" 
     .EvenPage.LeftFooter.Text = "" 
     .EvenPage.CenterFooter.Text = "" 
     .EvenPage.RightFooter.Text = "" 
     .FirstPage.LeftHeader.Text = "" 
     .FirstPage.CenterHeader.Text = "" 
     .FirstPage.RightHeader.Text = "" 
     .FirstPage.LeftFooter.Text = "" 
     .FirstPage.CenterFooter.Text = "" 
     .FirstPage.RightFooter.Text = "" 
    End With 

'Save and Close Workbook 
     wb.Close SaveChanges:=True 

    'Get next file name 
     myFile = Dir 
    Loop 

'Message Box when tasks are completed 
    MsgBox "Task Complete!" 

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

End Sub 

Answer 1

ou müssen durch alle Blätter in der Arbeitsmappe in einer Schleife, auch hinzugefügt Dim sht as Worksheet

Sub LoopAllExcelFilesInFolder() 

'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 
'SOURCE: www.TheSpreadsheetGuru.com 

Dim wb As Workbook 
Dim sht As Worksheet 
Dim myPath As String 
Dim myFile As String 
Dim myExtension 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" 

'Target Path with Ending Extention 
myFile = Dir(myPath & myExtension) 

'Loop through each Excel file in folder 
Do While myFile <> "" 
    'Set variable equal to opened workbook 
    Set wb = Workbooks.Open(Filename:=myPath & myFile) 

    ' added this line, loop through all worksheets in current wb 
    For Each sht In wb.Worksheets 

     'Change the layout 
     Application.PrintCommunication = False 
     With sht.PageSetup 
      .PrintTitleRows = "" 
      .PrintTitleColumns = "" 
     End With 
     Application.PrintCommunication = True 
     ActiveSheet.PageSetup.PrintArea = "" 
     Application.PrintCommunication = False 
     With sht.PageSetup 
      .LeftHeader = "" 
      .CenterHeader = "" 
      .RightHeader = "" 
      .LeftFooter = "" 
      .CenterFooter = "" 
      .RightFooter = "" 
      .LeftMargin = Application.InchesToPoints(0.7) 
      .RightMargin = Application.InchesToPoints(0.7) 
      .TopMargin = Application.InchesToPoints(0.75) 
      .BottomMargin = Application.InchesToPoints(0.75) 
      .HeaderMargin = Application.InchesToPoints(0.3) 
      .FooterMargin = Application.InchesToPoints(0.3) 
      .PrintHeadings = False 
      .PrintGridlines = False 
      .PrintComments = xlPrintNoComments 
      .PrintQuality = 600 
      .CenterHorizontally = False 
      .CenterVertically = False 
      .Orientation = xlLandscape 
      .Draft = False 
      .PaperSize = xlPaperLetter 
      .FirstPageNumber = xlAutomatic 
      .Order = xlDownThenOver 
      .BlackAndWhite = False 
      .Zoom = False 
      .FitToPagesWide = 1 
      .FitToPagesTall = False 
      .PrintErrors = xlPrintErrorsDisplayed 
      .OddAndEvenPagesHeaderFooter = False 
      .DifferentFirstPageHeaderFooter = False 
      .ScaleWithDocHeaderFooter = True 
      .AlignMarginsHeaderFooter = True 
      .EvenPage.LeftHeader.Text = "" 
      .EvenPage.CenterHeader.Text = "" 
      .EvenPage.RightHeader.Text = "" 
      .EvenPage.LeftFooter.Text = "" 
      .EvenPage.CenterFooter.Text = "" 
      .EvenPage.RightFooter.Text = "" 
      .FirstPage.LeftHeader.Text = "" 
      .FirstPage.CenterHeader.Text = "" 
      .FirstPage.RightHeader.Text = "" 
      .FirstPage.LeftFooter.Text = "" 
      .FirstPage.CenterFooter.Text = "" 
      .FirstPage.RightFooter.Text = "" 
     End With 
    Next sht 

    'Save and Close Workbook 
    wb.Close SaveChanges:=True 

    'Get next file name 
    myFile = Dir 
Loop 

'Message Box when tasks are completed 
MsgBox "Task Complete!" 

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

End Sub