从当前工作表粘贴到书的结尾到Word文档作为图片

我目前有一个工作macros（从TheSpreadsheetGuru修改代码），从A1复制到列H中最后一次使用的行，并将该数据作为图片粘贴到Microsoft Word文档。 它工作的很好，但我必须运行macros超过20次（每张一次），我有多个报告，我每周运行这个相同的标准。 是否有可能让这段代码遍历工作簿末尾的活动工作表（这将是所需的第一个工作表）中的所有工作表？ 我可以使用工作表名称（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语句来遍历数组和集合。 使用此方法可以在工作簿中的每个工作表上重复相同的操作。

 ' 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 

如果你想开始build立一个VBAmacros库，你可以从任何工作簿调用，研究Excel的启动path和.xla文件格式。