Excel-VBA Copy image from worksheet1 to worksheet 2 - excel

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.