Question

我无法按照预期将工作簿中的代码附加到函数中。一切正常，但它正在复制照片两次。有什么建议吗？

基本上，它查看主工作表，然后根据输入的日期为每个供应商创建一个唯一的工作表，并将所有记录复制到下一个空行。发生的事情是它复制了照片，但它粘贴了两次。我无法弄清楚原因。

代码显示在随附的工作簿中。

＆＃13;

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

＆＃13;

Workbook Example

Answer 1

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

WshtCrnt.Paste

以及属于此范围复制声明的一部分：

。。使用WshtSht1 .Range（.Cells（1,1），。Cell（RowSht1DataFirst - 1，ColSht1LastHdr））。Copy_ 目的地：= WshtCrnt.Range（ “A1”）。

通过指定“目的地”，您要求复制并粘贴您的范围。

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

1 个答案: