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

Question

我很难让工作簿中的代码按预期运行。一切正常，但它正在复制照片两次。有什么建议吗？

基本上，它会查看母版sheet，然后根据输入的日期为每个供应商创建唯一的sheet，并将所有记录复制到下一个空行。发生的事情是它复制了照片但粘贴了两次。我不明白为什么。

代码显示在附件工作簿中。

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

您的代码中有 2 个粘贴操作。你知道的一个：

WshtCrnt.Paste

还有一个是此范围复制语句的一部分：

。 . 与 WshtSht1 .Range(.Cells(1, 1), .Cells(RowSht1DataFirst - 1, ColSht1LastHdr)).Copy_ 目的地：=WshtCrnt.Range("A1") . .

通过指定 "Destination"，您请求复制并粘贴您的范围。

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

Excel-VBA Copy image from worksheet1 to worksheet 2

excel

vba

copy

image

paste