Excel-VBA将图像从工作表1复制到工作表2

Question

I am having difficulty getting the code in the workbook attached to function as intended. Everything is working but it is copying the photo twice. Any suggestions?

Basically, it looks at the master worksheet then creates a unique sheet for each supplier based on the date entered and copies over all records to the next empty line. What is happening is that it copies the photo over but it pastes it twice. I can't figure out why.

Code is shown in attached workbook.

 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 

Workbook Example

Answer 1

You have 2 paste operations in your code. One that you know of:

WshtCrnt.Paste

and one that is part of this range copy statement:

. . With WshtSht1 .Range(.Cells(1, 1), .Cells(RowSht1DataFirst - 1, ColSht1LastHdr)).Copy_ Destination:=WshtCrnt.Range("A1") . .

By specifying a "Destination" you are requesting a copy AND paste of your range.