将图像复制到目录中的所有工作簿

Question

我知道如何打开目录中的所有工作簿，我需要打开我的源工作簿，并从wbPicture.xlsx复制图像Picture 100，并为打开的每个wbdestination删除行下面的任何形状在wbdestination的每个工作表上都有84个。

我用Google搜索并发现您可以使用此功能将图像从一个工作簿复制到另一个工作簿，但如何解释每个工作表，以及如何删除现有图像（如果已经是一个）？ /强>

Sub CopyImage()
Dim imagewb As String
Dim openedwb As Workbook
Dim workbook As Workbook
Dim destbook As String
Dim totalbooks As Int
Dim bookname As String
Dim fulllist() As String

imagewb = "C:\Image.xlsx"
Set openedwb = Workbooks.Open(imagewb)

'Selecting image from template workbook
For Each shape in ActiveSheet.Shapes
  If shape.Name = "Picture 100" Then
    shape.Select
    shape.Copy
  End If
Next shape

Set WB = ActiveWorkbook

'Setting location of destination workbooks
destbook = "\\Hiya\ExcelFiles\"

totalbooks = 0
'Getting name of all .xlsx workbooks
bookname = Dir(destbook & "*.xlsx")

'Creating array
totalbooks = totalbooks + 1
ReDim Preserve fullList(1 To totalbooks)
fullList(totalbooks) = bookname
bookname = Dir()
Wend

For int totalbooks = 1 To UBound(fullList)
Set openedwb = Workbooks.Open(destbook & fullList(totalbooks))
'Selecting 1st sheet
Sheets(1).Select
'Pasting image from clipboard to workbook
With Sheets(1)
  .Paste(.Range("A81"))
End With

'Saving workbook & opening next
openedwb.Save
openedwb.Close False

End Sub

Answer 1

这将删除任何图像，无论参考范围中包含的名称等如何，在我的示例中，引用的范围是＆＃34; A81：Z250＆＃34;

For Each shape In ActiveSheet.Shapes
  If Not Application.Intersect(shape.TopLeftCell, .Range("A81:Z250")) Is Nothing Then
      If shape.Type = msoPicture Then
        shape.Delete
    End If
  End If
Next shape

要引用工作簿中包含的每个工作表，请直接从MSDN KB

提取

      Sub WorksheetLoop()

     Dim WS_Count As Integer
     Dim I As Integer

     ' Set WS_Count equal to the number of worksheets in the active
     ' workbook.
     WS_Count = ActiveWorkbook.Worksheets.Count

     ' Begin the loop.
     For I = 1 To WS_Count

        ' Insert your code here.
        ' The following line shows how to reference a sheet within
        ' the loop by displaying the worksheet name in a dialog box.
        MsgBox ActiveWorkbook.Worksheets(I).Name

     Next I

  End Sub