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”）。 。

通过指定“目标”，您需要复制和粘贴您的范围。