VBA Shapes Unaligning More And More

[Lewzerrrr]

I have a bit of code that will loop and add shapes to pre-formatted sheet, all row widths are the same, all column widths are the same.. as the macro loops more and more the shapes start to become out of place but ONLY down, they don't move left or right, just further down than what they should be.

Can anyone solve why?

                Set oNewPic = Sheets(template.Name).Shapes.AddPicture(Filename:=sFolder & .Cells(x, 10) & ".jpg", _                                                                      linktofile:=msoFalse, _
                                                                      savewithdocument:=msoCTrue, _
                                                                      Left:=rngPicPosition.Left, _
                                                                      Top:=rngPicPosition.Top, _
                                                                      Width:=-1, Height:=-1)
                With oNewPic
                    .Height = 100.629933
                    .Width = 92.6929242
                    .IncrementLeft 26.1
                    .IncrementTop 8.7
                    .LockAspectRatio = msoTrue
                    .Rotation = 0
                End With

 

[shg]

There's nothing in the code you posted that changes the range used to position the pictures.

 

[RoryA]

Do you have the page zoom set to anything other than 100%?

 

[Lewzerrrr]

There's nothing in the code you posted that changes the range used to position the pictures.

See full code..

Sub Box()

    Dim oNewPic As Shape
    Dim shpShape As Shape
    Dim rngPicPosition As Range
    Dim rngRange As Range
    Dim x As Long
    Dim iStartColumn As Long
    Dim iStartRow As Long
    Dim i As Long
    Dim j As Long
    
'   Speed up processing
    sbar ("Please wait ... importing pictures")
    Call TurnOff
    
'   Delete existing data, including pictures (Shapes)
    For Each shpShape In template.Shapes
        shpShape.Delete
    Next
    With template
        mylr = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
        mylc = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
        If mylr > 4 Then
            Set rngRange = .Range(.Cells(2, 2), .Cells(mylr, mylc))
            rngRange.ClearContents
            Call NoBorders(rngRange)
            rngRange.EntireRow.Delete
        End If
    End With
    
'   Insert Pictures
    i = 1
    j = 0
    With data
    
        mylr = LR(, .Name, "A")
        
        For x = 4 To mylr
        
            sbar ("Please wait ... importing picture " & i & " of " & mylr - 3)
            iStartColumn = MyColLong(CStr(.Cells(x, 16).Value))
            
            If iStartRow <> .Cells(x, 18) Then
                iStartRow = .Cells(x, 18)
                Worksheets(template.Name).Cells(iStartRow, 1).RowHeight = 118.75
            End If
            
            Set rngPicPosition = Worksheets(template.Name).Cells(iStartRow, iStartColumn)
            
            If FileExists(sFolder & .Cells(x, 10) & ".jpg") = False Then
            
                j = j + 1


            If FileExists(lFolder & .Cells(x, 10) & ".png") = False Then
            
                Dim PNF As Worksheet, LR1 As Long
                Set PNF = ThisWorkbook.Sheets("Pictures Not Found DIR")
                LR1 = PNF.Cells(PNF.Rows.Count, "A").End(xlUp).Row + 1
                
                If Application.WorksheetFunction.CountIf(PNF.Range("A2:A" & LR1), .Cells(x, 10)) > 0 Then
                
                Else
                
                 PNF.Range("A" & LR1) = .Cells(x, 10)
                 
                End If


            Else
                j = j - 1
                                Set oNewPic = Sheets(template.Name).Shapes.AddPicture(Filename:=lFolder & .Cells(x, 10) & ".png", _
                                                                      linktofile:=msoFalse, _
                                                                      savewithdocument:=msoCTrue, _
                                                                      Left:=rngPicPosition.Left, _
                                                                      Top:=rngPicPosition.Top, _
                                                                      Width:=-1, Height:=-1)
                With oNewPic
                    .Height = 100.629933
                    .Width = 92.6929242
                    .IncrementLeft 26.1
                    .IncrementTop 8.7
                    .LockAspectRatio = msoTrue
                    .Rotation = 0
                End With
                


                
            End If




                rngPicPosition.Offset(1, 0) = .Cells(x, 10)
                rngPicPosition.Offset(2, 0) = .Cells(x, 11)
                rngPicPosition.Offset(1, 1) = .Cells(x, 14)
                rngPicPosition.Offset(0, -1) = .Cells(x, 5)
                rngPicPosition.Offset(3, 0) = .Cells(x, 13)
                rngPicPosition.Offset(3, 0).NumberFormat = "0"
                rngPicPosition.Offset(3, 1) = .Cells(x, 12)
                rngPicPosition.Offset(3, 1).NumberFormat = "$#,##0.00"
                If .Cells(x, 14) <> "" Then rngPicPosition.Offset(2, 1) = .Cells(x, 24)
                rngPicPosition.Offset(2, 1).NumberFormat = "0.0"


                


                
                Set rngRange = rngPicPosition.Resize(5, 2)
                Call MyLineStyle(rngRange)
            Else
                Set oNewPic = Sheets(template.Name).Shapes.AddPicture(Filename:=sFolder & .Cells(x, 10) & ".jpg", _
                                                                      linktofile:=msoFalse, _
                                                                      savewithdocument:=msoCTrue, _
                                                                      Left:=rngPicPosition.Left, _
                                                                      Top:=rngPicPosition.Top, _
                                                                      Width:=-1, Height:=-1)
                With oNewPic
                    .Height = 100.629933
                    .Width = 92.6929242
                    .IncrementLeft 26.1
                    .IncrementTop 8.7
                    .LockAspectRatio = msoTrue
                    .Rotation = 0
                End With
                
                rngPicPosition.Offset(1, 0) = .Cells(x, 10)
                rngPicPosition.Offset(2, 0) = .Cells(x, 11)
                rngPicPosition.Offset(3, 0) = .Cells(x, 13)
                rngPicPosition.Offset(3, 0).NumberFormat = "0"
                rngPicPosition.Offset(1, 1) = .Cells(x, 14)
                rngPicPosition.Offset(0, -1) = .Cells(x, 5)
                rngPicPosition.Offset(3, 1) = .Cells(x, 12)
                rngPicPosition.Offset(3, 1).NumberFormat = "$#,##0.00"
                If .Cells(x, 14) <> "" Then rngPicPosition.Offset(2, 1) = .Cells(x, 24)
                rngPicPosition.Offset(2, 1).NumberFormat = "0.0"
                
                Set rngRange = rngPicPosition.Resize(5, 2)
                Call MyLineStyle(rngRange)
            End If
            i = i + 1
        Next x
    End With


    Set oNewPic = Nothing
    Set rngPicPosition = Nothing
    Set shpShape = Nothing
    Set rngRange = Nothing
    
    Call TurnOn
    
    Call MergeCells
    
    Call PrintArea
    
    Call WidthHeight
    
    mymsg = MsgBox(mylr - 3 & " Pictures have been processed, " & j & " of those were not found in the library.", vbOKOnly + vbInformation, "Information")


End Sub

 

[Lewzerrrr]

Any suggestions? Racking my brain so hard for this as not sure how to skip loop iterations to where it starts to become a problem.. I’ve tried tweaking a few lines of code but nothing appears to change it. My zoom is on 80% but even when it’s 100% it still occurs.