Forum Discussion

Copper Contributor

Jul 18, 2021

Solved

[VBA] Copy image to workbook

Hey everyone, I have an excel file with several formulas taking data from another "raw" excel file. This excel file is basically doing all the necessary calculations and automatically putting al...

Jul 18, 2021

For example:

Sub CopyToNew()
    Dim w1 As Worksheet
    Dim wb As Workbook
    Dim w2 As Worksheet
    Set w1 = ActiveSheet
    w1.UsedRange.SpecialCells(xlCellTypeVisible).Copy
    Set wb = Workbooks.Add
    Set w2 = wb.Worksheets(1)
    w2.Range("A1").PasteSpecial xlPasteColumnWidths
    w2.Range("A1").PasteSpecial xlPasteValues
    w2.Range("A1").PasteSpecial xlPasteFormats
    w1.Shapes("Picture 4").Copy
    w2.Paste
End Sub

HansVogelaar

MVP

Jul 18, 2021

Costafeller

For example:

Sub CopyToNew()
    Dim w1 As Worksheet
    Dim wb As Workbook
    Dim w2 As Worksheet
    Set w1 = ActiveSheet
    w1.UsedRange.SpecialCells(xlCellTypeVisible).Copy
    Set wb = Workbooks.Add
    Set w2 = wb.Worksheets(1)
    w2.Range("A1").PasteSpecial xlPasteColumnWidths
    w2.Range("A1").PasteSpecial xlPasteValues
    w2.Range("A1").PasteSpecial xlPasteFormats
    w1.Shapes("Picture 4").Copy
    w2.Paste
End Sub

Costafeller

Copper Contributor

Jul 19, 2021

HansVogelaar this is great thanks.

For it to be final, I just need to paste the image on a specific coordinate or cell, currently its pasting in the top left corner (A1).

Also, I just noticed now there was actually another image in the excel file, so I made a quick addition to what you provided me:

Sub CopyToNew()
    Dim w1 As Worksheet
    Dim wb As Workbook
    Dim w2 As Worksheet
    Set w1 = ActiveSheet
    w1.UsedRange.SpecialCells(xlCellTypeVisible).Copy
    Set wb = Workbooks.Add
    Set w2 = wb.Worksheets(1)
    w2.Range("A1").PasteSpecial xlPasteColumnWidths
    w2.Range("A1").PasteSpecial xlPasteValues
    w2.Range("A1").PasteSpecial xlPasteFormats
    w1.Shapes("Picture 4").Copy
    w2.Paste
    w1.Shapes("Gerade Verbindung 3").Copy
    w2.Paste
End Sub

HansVogelaar

MVP

Jul 19, 2021

Costafeller

I hope you can modify the following version for your situation:

Sub CopyToNew()
    Dim w1 As Worksheet
    Dim wb As Workbook
    Dim w2 As Worksheet
    Set w1 = ActiveSheet
    w1.UsedRange.SpecialCells(xlCellTypeVisible).Copy
    Set wb = Workbooks.Add
    Set w2 = wb.Worksheets(1)
    w2.Range("A1").PasteSpecial xlPasteColumnWidths
    w2.Range("A1").PasteSpecial xlPasteValues
    w2.Range("A1").PasteSpecial xlPasteFormats
    w1.Shapes("Picture 4").Copy
    w2.Paste
    With w2.Shapes("Picture 4")
        ' Change cell as needed
        .Top = w2.Range("B112").Top
        .Left = w2.Range("B112").Left
    End With
    w1.Shapes("Gerade Verbindung 3").Copy
    w2.Paste
    With w2.Shapes("Gerade Verbindung 3")
        ' Change cell as needed
        .Top = w2.Range("D75").Top
        .Left = w2.Range("D75").Left
    End With
End Sub

Costafeller
Copper Contributor
Jul 19, 2021
HansVogelaar
It's returning the following error because of row
With w2.Shapes("Picture 4")
- HansVogelaar
  MVP
  Jul 19, 2021
  Costafeller
  
  Strange - when I tested the code, it ran without errors. The copied/pasted shapes kept the same names as the original.