VBA Excel скопировать изображение из активной книги в другую книгу

Question

Этот вопрос может быть связан с этим:

Копировать изображение из одной рабочей книги в другую рабочую книгу

Но у него другой подход.

Моя цель - скопировать изображение из моей текущей рабочей книги в другую рабочую книгу, используя идентификатор изображения. В основном, если мы вставляем изображение, объект называется «Picture2», «Picture3», «Picture4» и т. Д. c.

. В этом случае я пытался установить универсальный код для этих имен. .

Весь мой код выглядит следующим образом:

 Sub Splicing()
  Dim PoP As String, SN As String
  Dim name As String, name2 As String, custom_name As String
  Dim Fibre As Variant
  Dim shp As Shape


  Dim newbook As Workbook
  Dim fs As Worksheet

  Set fw = Sheets("Frontsheet")
 'name = fw.Range("AA9")
  name = fw.Range("D18")
  name2 = fw.Range("D38")
  custom_name = name & " - Splicing As-build_v." & name2 & ".0"

  PoP = ActiveWorkbook.Sheets("Frontsheet").Range("D10").Value
  SN = ActiveWorkbook.Sheets("Frontsheet").Range("D12").Value


  Fibre = ThisWorkbook.Sheets("Fibre Drop Release Sheet").Range("A2:H20")

  Path = ActiveWorkbook.Path & "\Splicing Template_V1.0.xlsm"
  Set newbook = Workbooks.Open(Path)

  newbook.Sheets("Frontsheet").Cells(10, 4).Value = PoP
  newbook.Sheets("Frontsheet").Cells(12, 4).Value = SN


  newbook.Sheets("Fibre drop release sheet").Range("B3:H20").Value = Fibre

   ' COPYING THE PICTURE

  For Each shp In ActiveWorkbook.Shapes
  If shp.name Like "*Picture*" Then
    If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then
    shp.Copy
    Application.Goto newbook.Sheets("Locality").Range("A6")

    Rows(6).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 


    Workbooks(Path).Sheets("Locality").Paste
    End If
  End If
  Next shp

 ' END OF THE CODE WITH COPYING THE PICTURE


  Path = ActiveWorkbook.Path & "\" & custom_name & ".xlsm"

 'Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs filename:=Path, FileFormat:=52


  End Sub

Здесь я изменил свою часть кода

https://www.ozgrid.com/forum/index.php?thread / 149244-copy-image -от одной рабочей книги к другой рабочей книге /

Почему мой отладчик говорит, что ** объект не поддерживает этот метод ** в For Each ship in ActiveWorkbook.Shapes?

Как я могу настроить этот код, чтобы он работал?

Answer 1

Мой правильный код должен выглядеть следующим образом:

 Sub Splicing()
   Dim PoP As String, SN As String
   Dim name As String, name2 As String, custom_name As String
   Dim Fibre As Variant
   Dim shp As Shape


   Dim newbook As Workbook
   Dim fs As Worksheet, ls as Worksheet   'Dim my another source sheet

   Set fw = Sheets("Frontsheet")
   Set ls = Sheets("Location") ' Setting new worksheet in our document

   name = fw.Range("D18")
   name2 = fw.Range("D38")
   custom_name = name & " - Splicing As-build_v." & name2 & ".0"

   PoP = ActiveWorkbook.Sheets("Frontsheet").Range("D10").Value
   SN = ActiveWorkbook.Sheets("Frontsheet").Range("D12").Value


   Fibre = ThisWorkbook.Sheets("Fibre Drop Release Sheet").Range("A2:H20")

   Path = ActiveWorkbook.Path & "\Splicing Template_V1.0.xlsm"
   Set newbook = Workbooks.Open(Path)

   newbook.Sheets("Frontsheet").Cells(10, 4).Value = PoP
   newbook.Sheets("Frontsheet").Cells(12, 4).Value = SN


   newbook.Sheets("Fibre drop release sheet").Range("B3:H20").Value = Fibre

  ' COPYING THE PICTURE

  For Each shp In ls.Shapes  ' We are changing "Workbook" to the Worksheet set above
  If shp.name Like "*Picture*" Then
  shp.Copy
  Application.Goto newbook.Sheets("Locality").Range("A6")

  newbook.Sheets("Locality").Paste
  End If
  Next shp

  ' END OF THE CODE WITH COPYING THE PICTURE


  Path = ActiveWorkbook.Path & "\" & custom_name & ".xlsm"

 'Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs filename:=Path, FileFormat:=52


  End Sub

По сути, это простая реализация оператора For Each. Мы не копируем изображение с указанным именем, но изображение с потенциальным именем, которое соответствует нашему шаблону.