現在のシートからブックの最後までWord文書に画像として貼り付けます

Question

現在、A1から最後に使用された行をコピーしてMicrosoft Wordに貼り付ける作業マクロ（変更コードはTheSpreadsheetGuru）があります。資料。素晴らしいですが、マクロを20回以上（1枚ごとに1回）実行しなければならず、同じ基準で毎週実行するレポートが複数あります。このコードは、アクティブシート（必要な最初のシート）からワークブックの最後までのすべてのワークシートを反復することができますか？私はワークシート名を使用することができます（Lindaは最初です、Victoriaは最後のシートです）。名前はかなり頻繁に変更され、多くのシートが追加されることが多く、毎回コードを変更する必要はありません。

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ファイル形式。