將圖像複製到目錄中的所有工作簿

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