使用宏在工作表中復制圖像

Question

我在VBA中編寫了一個宏，該宏可以打開另一個工作簿，然后將工作表復制到活動工作簿中，然后再次關閉工作表。

除了工作表中包含的圖像不會復制外，所有這些都工作正常。 我在圖像應放置的位置獲得了一個占位符，並顯示文本“當前無法顯示此圖像”。

當我手動執行相同的步驟時，圖像復制不會出現問題。

為什么會發生這種情況，我該怎么解決？

編輯：下面的代碼。

Sub copy_sheet()

Dim wbk_current As Workbook
Set wbk_current = ActiveWorkbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim lastdate As String, filename As String

lastdate = Format(wbk_current.Worksheets(1).Range("D11") - 7, "ddmmyy")
filename = "C:\Folder\Filename " & lastdate & ".xlsx"

Dim wbk_old As Workbook
Set wbk_old = Workbooks.Open(filename)

wbk_old.Worksheets(2).Copy after:=wbk_current.Worksheets(1)
wbk_old.Close

Dim lastrow As Integer
lastrow = wbk_current.Worksheets(2).UsedRange.Rows.Count
weekrange = Format(wbk_current.Worksheets(1).Range("C11"), "dd/mm/yy") & " - " & Format(wbk_current.Worksheets(1).Range("D11"), "dd/mm/yy")

wbk_current.Worksheets(2).Rows(lastrow - 1 & ":" & lastrow - 1).Copy
wbk_current.Worksheets(2).Rows(lastrow & ":" & lastrow).Insert shift:=xlDown

wbk_current.Worksheets(2).Range("B" & lastrow).Value = wbk_current.Worksheets(2).Range("B" & lastrow - 1).Value + 1
wbk_current.Worksheets(2).Range("C" & lastrow) = weekrange
wbk_current.Worksheets(2).Range("D" & lastrow & ":J" & lastrow).Value = wbk_current.Worksheets(1).Range("C16:I16").Value

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

（前15條左右的線是相關的。）

據我所知，這應該與手動執行完全相同的操作-我是在復制工作表本身而不是內容。 當我手動執行時，圖像傳輸良好。 當我運行宏時，它確實拾取了一些東西 -但是它沒有顯示圖像，而是看起來像在圖像加載失敗時可能會在網頁上出現的錯誤。

Answer 1

這個問題比較老，但是既然還沒有答案，而且因為我遇到了同樣的問題：解決方案很簡單，盡管它還有其他明顯的缺點。

如果ScreenUpdating設置為False，Excel似乎無法復制圖片，因此在復制工作表之前根本不要取消激活ScreenUpdating或重新激活它。

Answer 2

我不太確定為什么會這樣。

嘗試以此為准則來處理您的代碼；

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim picName As String
    If Target.Column = 2 And Target.Row >= 5 Then
        picName = Target.Value
        Copy_Images picName
    End If
End Sub


Private Sub Copy_Images(imageName As String)
    Dim sh As Shape
    For Each sh In Sheets(2).Shapes
        If sh.Name = imageName Then
            sh.Copy
            Sheets(1).Pictures.Paste
        End If
    Next
End Sub