Pasting multiple ranges as Bitmaps into Word + Editing them

[jmfenn]

Hi excel masters,

I'm very new to VBA (this is my first post) and I'm trying to write a complicated code that will select a varying number of 32 row x 8 column boxes and paste them into a new word document as bitmap images, one on each page. I'm also trying to format each bitmap picture with a plain black border of 1.5 pt weight.

The code I have now can open up a new Word document and paste the first 26 ranges, but then it gives me an error and won't paste any more ranges. Also, none of the coding that I have tried today has succeeded in formatting an outline on the pictures.

Is anyone able to help me fix either of these issues? I'm at a loss for how to proceed. Here is the code I have been using:

Option Explicit


Sub WordCopyPaste3()


    Const wdWindowStateMaximize As Integer = 1
    Const wdPasteBitmap As Integer = 4
    Const wdPageBreak As Integer = 7
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim TotalCmp As Integer
    Dim oShape As Shape
    
    On Error GoTo CopyPaste_Error


' Finding the total number of ranges to paste (a variable number):
    ActiveWorkbook.Sheets("Inputs").Select
    ActiveSheet.Range("A1").Select
    Cells.Find(What:="Minimum Funding", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False).Activate
    ActiveCell.Offset(0, -1).Range("A1").Select
    Selection.End(xlUp).Select
    TotalCmp = ActiveCell.Range("A1").Value
         
' Opening a new Word Document
    Set WordApp = CreateObject("Word.Application")
        With WordApp
        .Visible = True
        .WindowState = wdWindowStateMaximize
        End With
    Set WordDoc = WordApp.Documents.Add
           
' Selecting the first range
    ActiveWorkbook.Sheets("Components").Select
    ActiveSheet.Range("B3").Select
    
' A running count for each range is one column over from the top left of the range to paste
    Do While ActiveCell.Offset(0, 1).Range("A1").Value <= TotalCmp And ActiveCell.Offset(0, 1).Range("A1").Value > 0
        ActiveCell.Range("A1:H31").Copy
            With WordApp
                .Selection.PasteSpecial DataType:=wdPasteBitmap 'I get an error on this line on the 27th range, although there are 32 ranges total
                .Selection.InsertBreak Type:=wdPageBreak
            End With
        Application.CutCopyMode = False
        ActiveCell.Offset(34, 0).Select
    Loop
    
' Exit code
    On Error GoTo 0
    Set WordApp = Nothing
    Set WordDoc = Nothing
    Set oShape = Nothing
    Exit Sub

' Error code
CopyPaste_Error:
    MsgBox "Module 21 Copy Paste Error", vbCritical, "ERROR"
    On Error GoTo 0


End Sub

 

[jmfenn]

Solved it! Sort of. I've explained how for future users with the same problem.

Office simply won't let me paste a 27th bitmap in one macro. Even if I run my macro for 26 ranges and then manually copy and paste, it doesn't work. At first I made two macros: one for the first 26 ranges and one for the next 26, however this was pretty clunky. I figure that the office clipboard was full, but I don't know a way around this.

I ended up pasting everything as enhanced metafiles, which actually works better than bitmaps. Not only do they seem to be better quality, but now I can use the selectall feature (I couldn't with Bitmap). This appears to get rid of the 26 range issue, although I've only tried it with 32 ranges so far. As for the outline issue, I simply created a border around each range and selected an extra row and column on every side of the range, which works for me. It might be that using enhanced metafiles would solve that issue, too, but I don't know. Here's the relevant piece of coding:

Option Explicit


Sub WordCopyPaste3()


    Const wdWindowStateMaximize As Integer = 1
    Const wdPageBreak As Integer = 7
    Dim WordApp As Object
    Dim TotalCmp As Integer
    
    On Error GoTo CopyPaste_Error


' Finding the total number of components (a variable number):
    ActiveWorkbook.Sheets("Inputs").Select
    ActiveSheet.Range("A1").Select
    Cells.Find(What:="Minimum Funding", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False).Activate
    ActiveCell.Offset(0, -1).Range("A1").Select
    Selection.End(xlUp).Select
    TotalCmp = ActiveCell.Range("A1").Value
         
' Opening a new Word Document
    Set WordApp = CreateObject("Word.Application")
    With WordApp
        .Visible = True
        .WindowState = wdWindowStateMaximize
        .Documents.Add
        .Selection.PasteSpecial DataType:=wdPasteenhancedmetafile, Placement:=wdInLine
    End With
           
' Selecting the first range
    ActiveWorkbook.Sheets("Components").Select
    ActiveSheet.Range("A2").Select
    
' A running count of components is now one row down and two columns over from the top left of the range to paste
    Do While ActiveCell.Offset(1, 2).Range("A1").Value <= TotalCmp And ActiveCell.Offset(1, 2).Range("A1").Value > 0
        ActiveCell.Range("A1:J33").Copy
        WordApp.Selection.PasteSpecial DataType:=wdPasteenhancedmetafile, Placement:=wdInLine
        Application.CutCopyMode = False
        ActiveCell.Offset(34, 0).Select
    Loop
        On Error GoTo 0
        Exit Sub
    

' Error code
CopyPaste_Error:
    MsgBox "Module 19 Copy Paste Error", vbCritical, "ERROR"
    On Error GoTo 0


End Sub

 

[jmfenn]

Sorry... that last code is a little wrong. Here's the one that works.

Option Explicit


Sub WordCopyPaste3()


    Const wdWindowStateMaximize As Integer = 1
    Const wdPageBreak As Integer = 7
    Dim WordApp As Object
    Dim TotalCmp As Integer
    
    On Error GoTo CopyPaste_Error


' Finding the total number of components (a variable number):
    ActiveWorkbook.Sheets("Inputs").Select
    ActiveSheet.Range("A1").Select
    Cells.Find(What:="Minimum Funding", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True, SearchFormat:=False).Activate
    ActiveCell.Offset(0, -1).Range("A1").Select
    Selection.End(xlUp).Select
    TotalCmp = ActiveCell.Range("A1").Value
         
' Opening a new Word Document
    Set WordApp = CreateObject("Word.Application")
    With WordApp
        .Visible = True
        .WindowState = wdWindowStateMaximize
        .Documents.Add
    End With
           
' Selecting the first range
    ActiveWorkbook.Sheets("Components").Select
    ActiveSheet.Range("A2").Select
    
' A running count of components is one row down and two columns over from the top left of the range to paste
    Do While ActiveCell.Offset(1, 2).Range("A1").Value <= TotalCmp And ActiveCell.Offset(1, 2).Range("A1").Value > 0
        ActiveCell.Range("A1:J33").Copy
        WordApp.Selection.PasteSpecial DataType:=wdPasteenhancedmetafile, Placement:=wdInLine
        Application.CutCopyMode = False
        ActiveCell.Offset(34, 0).Select
    Loop
    On Error GoTo 0
    Set WordApp = Nothing
    Exit Sub


' Error code
CopyPaste_Error:
    MsgBox "Module 19 Copy Paste Error", vbCritical, "ERROR"
    On Error GoTo 0
    Application.Calculation = xlCalculationAutomatic


End Sub