Importing Pictures From Directory Unaligning The Further It Loops

[Lewzerrrr]

Hi all,

I have a piece of code that imports pictures from my directory in columns of 10 by X rows. For every row imported it seems to shift down by a pixel, overtime this starts to notice if I was to run it for a 1000 row, it would be shifted further down than what it should be.

Now I can't for the life of me understand why as I'm not sure how to skip loop iterations through F8 to understand what it's doing. Here's the following 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

I think it's something to do with this line of code but unsure why it would come out of sync?

Any help would be greatly appreciated!

                                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)

OR if anyone knows how to test if all shapes in a worksheet = incrementleft 26.1 incrementtop 8.7, if not then re-adjust?

What I do at the moment is F5 Objects, Cut and Copy it back into first cell, however this pastes as one picture now instead of multiple so I have to drag across and down?

[alansidman]

crosspost: https://www.ozgrid.com/forum/forum/h...rther-it-loops

Your post does not comply with Rule 8 of our Forum RULES. Do not crosspost your question on multiple forums without including links here to the other threads on other forums.

Cross-posting is when you post the same question in other forums on the web. The last thing you want to do is waste people's time working on an issue you have already resolved elsewhere. We prefer that you not cross-post at all, but if you do (and it's unlikely to go unnoticed), you MUST provide a link (copy the url from the address bar in your browser) to the cross-post.

Expect cross-posted questions without a link to be closed and a message will be posted by the moderator explaining why. We are here to help so help us to help you!

Read this to understand why we ask you to do this, and then please edit your first post to include links to any and all cross-posts in any other forums (not just this site).