Question

我有以下代码将循环遍历worksheets的所有workbook，并将通过删除，更改页面方向，页边距以及能够在1张纸上打印每张纸来格式化每张纸。

下面它正在工作，但需要时间Call editingProperties很长，需要时间才能完成所有工作表。

有没有更好的方法来编写editingProperties sub？

 Dim ws As Worksheet

Public Sub editAllSheets()

' Keyboard Shortcut: Ctrl+Shift+E
'
Dim myResult As VbMsgBoxResult

myResult = MsgBox("Are you sure you want to edit all sheets in this workbook?", vbQuestion + vbOKCancel + vbDefaultButton1, "Edit workbook")
If myResult = vbCancel Then Exit Sub

   On Error GoTo ErrorHandler

        For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        Application.ScreenUpdating = False
        Call editingProperties
        Application.ScreenUpdating = True
            Next ws
        Sheets.Select
        MsgBox "Please note:" & vbNewLine & vbNewLine & "1. All the sheets are selected." & vbNewLine & "2. Proceed with print preview to view and print all reports." & vbNewLine & "3. To print preview or print only 1 report of this workbook you need to click on a different sheet to deselect all.", vbInformation, "Process Completed!"

    Exit Sub '<--- exit here if no error occured
ErrorHandler:
    MsgBox "Sorry, an error occured." & vbCrLf & Err.Description, vbCritical, "Error!"

End Sub

Private Sub editingProperties()

    Columns("A:E").Select
    Range("A4").Activate
    Selection.UnMerge
    Columns("B:C").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:D").Select
    Selection.Delete Shift:=xlToLeft
    Columns("E:G").Select
    Selection.Delete Shift:=xlToLeft
    Columns("H:J").Select
    Selection.Delete Shift:=xlToLeft
    Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
    Range("A1:B2").Select
    Selection.Merge
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    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 = 100
        .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
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .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 = 100
        .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
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .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 = 1
        .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
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .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 = 1
        .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 = ""
         Cells.Select
         Cells.EntireColumn.AutoFit
         Range("A3").Select

    End With

End Sub

Answer 1

请查看下面代码的结构。我纠正了一些错误，做了一些改进，并开始介绍如何编写长长的属性列表。当您继续添加到列表时，请确保不复制所有重复。只需设置一次属性即可。

Public Sub EditAllSheets()
    ' 01 Apr 2017
    ' Keyboard Shortcut: Ctrl+Shift+E

    Dim Ws As Worksheet
    Dim myResult As VbMsgBoxResult

    If MsgBox("Are you sure you want to edit all sheets in this workbook?", _
                      vbQuestion Or vbYesNo Or vbDefaultButton1, _
                      "Edit workbook") <> vbYes Then Exit Sub

    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False
    For Each Ws In ActiveWorkbook.Worksheets
        EditProperties Ws
    Next Ws

    Sheets.Select
    MsgBox "Please note:" & vbCr & vbCr & _
           "1. All the sheets are selected." & vbCr & _
           "2. Proceed with print preview to view and print all reports." & vbCr & _
           "3. To print preview or print only 1 report of this workbook" & vbCr & _
           "    you need to click on a different sheet to deselect all.", _
           vbInformation, "Process Completed!"

    Application.ScreenUpdating = True
    Exit Sub '<--- exit here if no error occured

ErrorHandler:
    MsgBox "Sorry, an error occured." & vbCrLf & Err.Description, vbCritical, "Error!"
    Application.ScreenUpdating = True
End Sub

Private Sub EditProperties(Ws As Worksheet)
    ' 01 Apr 2017

    With Ws
        .Range(Columns(1), Columns(5)).UnMerge
        ' .Range(Columns("A"), Columns("E")).UnMerge      ' can also work
        .Range(Columns(2), Columns(11)).Delete shift:=xlToLeft
        .Range("A1:B2").Merge
        With .PageSetup
            .PrintTitleRows = ""
            .PrintTitleColumns = ""
            .PrintArea = ""
            .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
        End With
    End With
End Sub

Answer 2

是的，您的代码现在可以从右到左正确删除列。我指出.Columns（＆＃34; T：T＆＃34;）与.Columns（＆＃34; T＆＃34;）相同，它与.Columns（20）相同。

作为连续删除列的替代方法，您可以将它们合并到一个范围中，然后删除范围，如下所示。

Dim Rng As Range

With Ws
    Set Rng = Application.Union(.Columns("B:C"), _
                                .Columns("E:F"), _
                                .Columns("J:H"), _
                                .Columns("N:P"), _
                                .Columns("T"))
    Rng.Delete
End With

请务必不要重复＆＃34; With Ws .... End With。重复不会造成伤害，但会降低代码的可读性。

如何更好地格式化VBA中的所有工作表？

2 个答案: