如何復制附加在工作表上的圖像並將其粘貼到新工作表中

Question

我有用於從一個工作表復制圖像並將其粘貼到新工作簿上的代碼。 我的問題是，“僅當圖像附加在范圍內時，它才起作用。我希望即使圖像附加在工作表上 ，代碼也能起作用”。

注意：輸入文件可能包含多個圖像

我的代碼是：

Set xlwbkinput = ActiveWorkbook
Set xlwbkoutput = Excel.Workbooks.Add

shtcountip = xlwbkinput.Sheets.Count
shtcountop = xlwbkoutput.Sheets.Count

If shtcountop < shtcountip Then
    For i = shtcountop To shtcountip + 1
            xlwbkoutput.Worksheets.Add After:=xlwbkoutput.Worksheets(xlwbkoutput.Worksheets.Count)
    Next i
End If


    For i = 1 To shtcountip 'it runs till the input workbook have the last sheet

        xlwbkinput.Worksheets(i).Activate
        xlwbkinput.Worksheets(i).Range("A1:AZ200").Copy 'here I'm copying input sheet 
        xlwbkoutput.Worksheets(i).Activate
        xlwbkoutput.Worksheets(i).Paste 'here I'm pasting in my new worksheet

    Next i

提前致謝！！！！

Answer 1

下面的For循環將遍歷xlwbkinput.Worksheets(1) （索引為1的工作表xlwbkinput.Worksheets(1)所有形狀。

然后，它檢查當前Shape （圖片）單元格的位置是否大於1，這意味着它檢查當前圖片是否位於從第二行開始的任何單元格中-您可以輕松地修改該條件。

Dim myPics As Shape

' loop through all shapes in Worksheets(1)
For Each myPics In xlwbkinput.Worksheets(1).Shapes
    If myPics.TopLeftCell.Row > 1 Then   ' check if current shape's row is larger than 1
        myPics.Copy '<-- copy the current picture
    End If
Next myPics

Answer 2

嘗試以下方法：

Option Explicit

Public Sub tmpSO()

Dim picIn As Picture
Dim picOut As Picture
Dim wksInput As Worksheet
Dim wksOutput As Worksheet
Dim cht As ChartObject

Set wksInput = ThisWorkbook.Worksheets("Sheet1")
Set wksOutput = ThisWorkbook.Worksheets("Sheet2")

For Each picIn In wksInput.Pictures
    Set cht = wksInput.ChartObjects.Add(0, 0, picIn.Width, picIn.Height)
    cht.Chart.Parent.Border.LineStyle = 0

    picIn.Copy
    cht.Chart.ChartArea.Select
    cht.Chart.Paste

    cht.Chart.Export Filename:=Environ("Temp") & "\someTempPicName.jpg", filtername:="JPG"
    Set picOut = wksOutput.Pictures.Insert(Environ("Temp") & "\tmpPic5022.jpg")
    picOut.Left = picIn.Left
    picOut.Top = picIn.Top

    cht.Delete
    Kill Environ("Temp") & "\someTempPicName.jpg"
Next picIn

End Sub

此解決方案使用worksheet.Pictures集合來迭代worksheet.Pictures上的所有圖片。 最簡單的方法是.Paste這些圖片從一張紙.Copy並.Paste到另一張紙。 但是，這種方法會忽略每張圖片在紙張上的位置。 假設您希望圖片不在輸出圖紙上隨機放置，上述代碼還將復制輸入圖紙上的位置。