Excel-VBA將圖像從工作表1復制到工作表2

Question

我很難使工作簿中的代碼按預期方式附加到功能上。 一切正常，但是它已將照片復制了兩次。 有什么建議么？

基本上，它查看主工作表，然后根據輸入的日期為每個供應商創建一個唯一的表，並將所有記錄復制到下一個空行。 發生的情況是它復制了照片，但粘貼了兩次。 我不知道為什么。

代碼顯示在隨附的工作簿中。

 Option Explicit Const ColSht1Name As Long = 1 Const RowSht1DataFirst As Long = 2 Const ColSht1Date As Date = 3 Const ColSht1Doc As String = 4 Sub BuildSingleSupplierSheets() ' For each supplier in worksheet Sheet1, create their own worksheet. ' Copy each data row for a supplier, including a picure if any, to its own worksheet. Dim ColSht1LastHdr As Long Dim ColSht1LastCrnt As Long Dim ColShapeTopLeftCell As Long Dim Found As Boolean Dim HeightShape As Single Dim InxShape As Long ' Dim RowPerPicture() As String Dim RngDest As Range Dim RowCrntNext As Long Dim RowSht1Crnt As Long Dim RowSht1Last As Long Dim ShapeCrnt As Shape Dim WshtSht1 As Worksheet Dim WshtCrnt As Worksheet Dim WshtNameCrnt As String Dim x As String Dim bottomL As Integer Dim c As Range Set WshtSht1 = Worksheets("Sheet1") x = InputBox("Enter Report Date") With Worksheets("Sheet1") RowSht1Last = .Cells(Rows.Count, ColSht1Name).End(xlUp).Row ColSht1LastHdr = 0 For RowSht1Crnt = 1 To RowSht1DataFirst - 1 ColSht1LastCrnt = .Cells(RowSht1Crnt, Columns.Count).End(xlToLeft).Column If ColSht1LastHdr < ColSht1LastCrnt Then ColSht1LastHdr = ColSht1LastCrnt End If Next End With ' Copy every row from worksheet Sheet1 to the worksheet for the row's ' supplier. Create and initialise supplier worksheet if it does not ' already exist. For RowSht1Crnt = RowSht1DataFirst To RowSht1Last If WshtSht1.Cells(RowSht1Crnt, ColSht1Date).Value = x And WshtSht1.Cells(RowSht1Crnt, "B").Value = "DR" Then WshtNameCrnt = WshtSht1.Cells(RowSht1Crnt, ColSht1Name).Value ' Create and initiialise worksheet WshtNameCrnt if it does not already exist If Not SheetExists(WshtNameCrnt) Then Set WshtCrnt = Worksheets.Add(After:=Worksheets(Worksheets.Count)) WshtCrnt.Name = WshtNameCrnt With WshtSht1 .Range(.Cells(1, 1), .Cells(RowSht1DataFirst - 1, ColSht1LastHdr)).Copy _ Destination:=WshtCrnt.Range("A1") End With Else Set WshtCrnt = Worksheets(WshtNameCrnt) End If ' Copy current row of worksheet Sheet1 to the next free row ' of the supplier worksheet RowCrntNext = LastRow(WshtCrnt) + 1 With WshtSht1 ColSht1LastCrnt = .Cells(RowSht1Crnt, Columns.Count).End(xlToLeft).Column .Range(.Cells(RowSht1Crnt, 1), .Cells(RowSht1Crnt, ColSht1LastCrnt)).Copy _ Destination:=WshtCrnt.Cells(RowCrntNext, 1) End With ' Ensure columns wide enought for data With WshtCrnt .Cells.Range(.Cells(1, 1), .Cells(1, ColSht1LastCrnt)).EntireColumn.AutoFit .Cells.Range(.Cells(1, 1), .Cells(1, ColSht1LastCrnt)).Borders(xlEdgeBottom).Color = RGB(0, 0, 0) .Cells.Range(.Cells(1, 1), .Cells(1, ColSht1LastCrnt)).Borders(xlEdgeTop).Color = RGB(0, 0, 0) .Cells.Range(.Cells(1, 1), .Cells(1, ColSht1LastCrnt)).Borders(xlInsideHorizontal).Color = RGB(0, 0, 0) .Cells.Range(.Cells(1, 1), .Cells(1, ColSht1LastCrnt)).Borders(xlInsideVertical).Color = RGB(0, 0, 0) End With ' Check Shapes collection to see if there is a picture on this row With WshtSht1 Found = False For InxShape = 1 To .Shapes.Count With .Shapes(InxShape) If .Type = msoPicture Then If .TopLeftCell.Row = RowSht1Crnt Then Found = True Exit For End If End If End With Next End With If Found Then ' Picture on current row of Sheet1. Copy to supplier worksheet Set ShapeCrnt = WshtSht1.Shapes(InxShape) With ShapeCrnt ColShapeTopLeftCell = .TopLeftCell.Column HeightShape = .Height End With ShapeCrnt.Copy WshtCrnt.Paste With WshtCrnt Set RngDest = .Cells(RowCrntNext, ColShapeTopLeftCell) RngDest.RowHeight = HeightShape + 4! With .Shapes(.Shapes.Count) .Top = RngDest.Top + 2! .Left = RngDest.Left + 2! Call .ScaleWidth(1!, msoCTrue) ' Call .ScaleHeight(1!, msoCTrue) ' End With End With End If End If Next RowSht1Crnt End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function SheetExists(SName As String, _ Optional ByVal WB As Workbook) As Boolean 'Chip Pearson On Error Resume Next If WB Is Nothing Then Set WB = ThisWorkbook SheetExists = CBool(Len(WB.Sheets(SName).Name)) End Function 

工作簿示例

Answer 1

您的代碼中有2個粘貼操作。 您知道的一個：

粘貼粘貼

並且是該范圍復制語句的一部分：

。 。 與WshtSht1 .Range（.Cells（1，1），.Cells（RowSht1DataFirst-1，ColSht1LastHdr））。Copy_ Destination：= WshtCrnt.Range（“ A1”）。 。

通過指定“目標”，您需要復制和粘貼您的范圍。