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

Question

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

我搜索了一下，发现你可以使用它将图像从一个工作簿复制到另一个工作簿，但是如何解释每个工作表以及如何删除现有图像（如果它们已经是一个）？

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

这将删除任何图像，而不管包含在所引用的范围名称等，在我的例子被引用的范围是“A81：Z250”

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