Question

我目前有一个工作宏（来自TheSpreadsheetGuru的修改代码），它从A1复制到H列中的最后一行，并将该数据作为图片粘贴到Microsoft Word文档。它工作得很好，但我必须运行宏超过20次（每张一次），我有多个报告，我每周运行相同的标准。是否有可能让代码遍历活动工作表中的所有工作表（这将是所需的第一个工作表）直到工作簿的末尾？我可以使用工作表名称（Linda是第一个，维多利亚是最后一页），但名称经常更改，经常添加更多工作表，我不想每次都更改代码。

    Sub PasteAsPicture()

    Dim tbl As Excel.Range
    Dim WordApp As Word.Application
    Dim myDoc As Word.Document
    Dim lastrow As Long
    Dim startcell As Range

    Set startcell = Range("H4")
    PicNme = ActiveSheet.name & ".docx"

    'Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    'Copy Range from Excel
    With ActiveSheet
        lastrow = ActiveSheet.Cells(.Rows.Count, startcell.Row).End(xlUp).Row
        Set tbl = ActiveSheet.Range("A1:H" & lastrow)
    End With

    'Create an Instance of MS Word
    On Error Resume Next

    'Is MS Word already opened?
    Set WordApp = GetObject(class:="Word.Application")

    'Clear the error between errors
    Err.Clear

    'If MS Word is not already open then open MS Word
    If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")

    'Handle if the Word Application is not found
    If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
    End If

  On Error GoTo 0

    'Make MS Word Visible and Active
    'WordApp.Visible = True
    'WordApp.Activate

    'Create a New Document
    Set myDoc = WordApp.documents.Add

    'Copy Excel Table Range
    tbl.CopyPicture xlPrinter

    'Paste Table into MS Word
    With myDoc.PageSetup
        .Orientation = wdOrientLandscape
        .TopMargin = WordApp.InchesToPoints(1)
        .BottomMargin = WordApp.InchesToPoints(1)
        .LeftMargin = WordApp.InchesToPoints(0.5)
        .RightMargin = WordApp.InchesToPoints(0.5)
    End With

    With myDoc
        .Paragraphs(1).Range.Paste
        .SaveAs Filename:="H:\QBIRT Reports\New Establishments\Reports\" & PicNme
        .Close
    End With

EndRoutine:
    'Optimize Code
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    'Clear The Clipboard
    Application.CutCopyMode = False

End Sub

Answer 1

VBA使用For Each... Next Statement循环遍历数组和集合。使用此方法，您可以在工作簿中的每个工作表上重复相同的操作。

' Calls PasteAsPicture, for each sheet in the workbook.
Sub ForEachWorksheet()
    Dim ws As Worksheet

    ' Loop over every sheet in the book.
    For Each ws In ThisWorkbook.Sheets

        ' Paste as picture requires the current sheet to be selected.
        ' You cannot activate hidden and very hidden sheets, without first unhiding.
        If ws.Visible = xlSheetVisible Then


            ws.Activate
            PasteAsPicture
        End If
    Next
End Sub

如果要开始构建可以从任何工作簿调用的VBA宏库，请研究Excel的启动路径和.xla文件格式。

从当前工作表粘贴到书末，将其作为图片粘贴到Word文档中

1 个答案: