VBA code shifts a cell

[KlausW]

Hi
I have a challenge. I use this VBA code to find the image names in a folder. And import the images. It works really well. The problem is that it shifts the last image one cell down in relation to the image name.
Any help will be appreciated.
Best regards
Klaus W

Sub Rektangelafrundedehjørner2_Klik()
Const factor = 0.9  'picture is 90% of the size of cell

    'Variable Declaration
    Dim fsoLibrary As FileSystemObject
    Dim fsoFolder As Object
    Dim sFolderPath As String
    Dim sFileName As Object
    Dim p As Object

    Dim i As Long   'counter
    Dim last_row As Long
    Dim ws As Worksheet

        sFolderPath = "D:\Billeder f-div grej\"  'may need to change this line to suit your situation

    
    'Set all the references to the FSO Library
    Set fsoLibrary = CreateObject("Scripting.FileSystemObject")
    Set fsoFolder = fsoLibrary.GetFolder(sFolderPath)
    Set ws = ThisWorkbook.Sheets("Ark1")
    On Error Resume Next
    
    With ws
        .Range("A1") = "Navn"
        .Range("B1") = "Billede"
    
        'Loop through each file in a folder
        i = 2
        For Each sFileName In fsoFolder.Files
            .Cells(i, 1) = Left(sFileName.Name, InStr(sFileName.Name, ".") - 1)
            i = i + 1
            '        Debug.Print sFileName.Name
        Next sFileName
        
        last_row = i
        
        Range(.Cells(2, 1), .Cells(i, 1)).Sort key1:=.Cells(2, 1), order1:=xlDescending
    
        For i = 2 To last_row Step 1
    
            Set p = .Shapes.AddPicture(FileName:=sFolderPath _
                & Cells(i, 1).Value & ".jpg", LinkToFile:=False, SaveWithDocument:=True, _
                Left:=.Cells(i, 2).Left, Top:=Cells(i, 2).Top, Width:=-1, Height:=-1)

            p.Width = .Cells(i, 2).Width * factor
            'adjust row height
            If .Cells(i, 2).RowHeight < p.Height / factor Then
                .Cells(i, 2).RowHeight = p.Height / factor
            End If

            p.Left = .Cells(i, 2).Left + (.Cells(i, 2).Width - p.Width) / 2
            p.Top = .Cells(i, 2).Top + (.Cells(i, 2).Height - p.Height) / 2
            Next i
        End With
    
    'Release the memory
    Set fsoLibrary = Nothing
    Set fsoFolder = Nothing
End Sub

 

[Georgiboy]

I think maybe part of the issue is that you have used: 'On Error Resume Next' without switching it back on after, this means that you will not see any further errors - even if you probably should.

If you take that line out you will notice that it tries to process one more file than what is in the folder and therefore is moving to the next cell in the loop but still looking at the previous image. The reason for it processing one more file than what is there is due to the way you have set 'last_row'

As you have started 'i' at the value of 2, when your loop 'For Each sFileName In fsoFolder.Files' has completed 'i' will be greater than the count of rows with data on your 'Ark1' sheet.

THE FIX:
Remove the line: 'On Error Resume Next'
Change 'last_row = i' to 'last_row = i - 1'

Hope this helps

 

[Jimmypop]

Hello @KlausW

You can maybe try the below as well... I have tested and seem to work on my side. Not sure what your data should like like but gave it a try... it may be that you are incrementing the i counter before adding the image which I think might be the problem... I have also tried to keep your references in one place. Try:

Sub Rektangelafrundedehjørner2_Klik()
Const factor = 0.9  'picture is 90% of the size of cell

    'Variable Declaration
    Dim fsoLibrary As FileSystemObject
    Dim fsoFolder As Object
    Dim sFolderPath As String
    Dim sFileName As Object
    Dim p As Object

    Dim i As Long   'counter
    Dim last_row As Long
    Dim ws As Worksheet

    'Set all the references to the FSO Library
    Set fsoLibrary = CreateObject("Scripting.FileSystemObject")
    sFolderPath = "D:\Billeder f-div grej\"  'may need to change this line to suit your situation
    Set fsoFolder = fsoLibrary.GetFolder(sFolderPath)
    Set ws = ThisWorkbook.Sheets("Ark1")
    On Error Resume Next
    
    With ws
        .Range("A1") = "Navn"
        .Range("B1") = "Billede"
    
        'Loop through each file in a folder
        i = 2
        For Each sFileName In fsoFolder.Files
            .Cells(i, 1) = Left(sFileName.Name, InStr(sFileName.Name, ".") - 1)
            
            Set p = .Shapes.AddPicture(Filename:=sFolderPath _
                & Cells(i, 1).Value & ".jpg", LinkToFile:=False, SaveWithDocument:=True, _
                Left:=.Cells(i, 2).Left, Top:=Cells(i, 2).Top, Width:=-1, Height:=-1)

            p.Width = .Cells(i, 2).Width * factor
            'adjust row height
            If .Cells(i, 2).RowHeight < p.Height / factor Then
                .Cells(i, 2).RowHeight = p.Height / factor
            End If

            p.Left = .Cells(i, 2).Left + (.Cells(i, 2).Width - p.Width) / 2
            p.Top = .Cells(i, 2).Top + (.Cells(i, 2).Height - p.Height) / 2
            
            i = i + 1
        Next sFileName
        
        last_row = i
        
        Range(.Cells(2, 1), .Cells(i, 1)).Sort key1:=.Cells(2, 1), order1:=xlDescending
    End With
    
    'Release the memory
    Set fsoLibrary = Nothing
    Set fsoFolder = Nothing
End Sub

 

[KlausW]

I think maybe part of the issue is that you have used: 'On Error Resume Next' without switching it back on after, this means that you will not see any further errors - even if you probably should.

If you take that line out you will notice that it tries to process one more file than what is in the folder and therefore is moving to the next cell in the loop but still looking at the previous image. The reason for it processing one more file than what is there is due to the way you have set 'last_row'

As you have started 'i' at the value of 2, when your loop 'For Each sFileName In fsoFolder.Files' has completed 'i' will be greater than the count of rows with data on your 'Ark1' sheet.

THE FIX:
Remove the line: 'On Error Resume Next'
Change 'last_row = i' to 'last_row = i - 1'

Hope this helps

Thank allot

 

[KlausW]

Hello @KlausW

You can maybe try the below as well... I have tested and seem to work on my side. Not sure what your data should like like but gave it a try... it may be that you are incrementing the i counter before adding the image which I think might be the problem... I have also tried to keep your references in one place. Try:

Sub Rektangelafrundedehjørner2_Klik()
Const factor = 0.9  'picture is 90% of the size of cell

    'Variable Declaration
    Dim fsoLibrary As FileSystemObject
    Dim fsoFolder As Object
    Dim sFolderPath As String
    Dim sFileName As Object
    Dim p As Object

    Dim i As Long   'counter
    Dim last_row As Long
    Dim ws As Worksheet

    'Set all the references to the FSO Library
    Set fsoLibrary = CreateObject("Scripting.FileSystemObject")
    sFolderPath = "D:\Billeder f-div grej\"  'may need to change this line to suit your situation
    Set fsoFolder = fsoLibrary.GetFolder(sFolderPath)
    Set ws = ThisWorkbook.Sheets("Ark1")
    On Error Resume Next
   
    With ws
        .Range("A1") = "Navn"
        .Range("B1") = "Billede"
   
        'Loop through each file in a folder
        i = 2
        For Each sFileName In fsoFolder.Files
            .Cells(i, 1) = Left(sFileName.Name, InStr(sFileName.Name, ".") - 1)
           
            Set p = .Shapes.AddPicture(Filename:=sFolderPath _
                & Cells(i, 1).Value & ".jpg", LinkToFile:=False, SaveWithDocument:=True, _
                Left:=.Cells(i, 2).Left, Top:=Cells(i, 2).Top, Width:=-1, Height:=-1)

            p.Width = .Cells(i, 2).Width * factor
            'adjust row height
            If .Cells(i, 2).RowHeight < p.Height / factor Then
                .Cells(i, 2).RowHeight = p.Height / factor
            End If

            p.Left = .Cells(i, 2).Left + (.Cells(i, 2).Width - p.Width) / 2
            p.Top = .Cells(i, 2).Top + (.Cells(i, 2).Height - p.Height) / 2
           
            i = i + 1
        Next sFileName
       
        last_row = i
       
        Range(.Cells(2, 1), .Cells(i, 1)).Sort key1:=.Cells(2, 1), order1:=xlDescending
    End With
   
    'Release the memory
    Set fsoLibrary = Nothing
    Set fsoFolder = Nothing
End Sub

Both of the solution works, thanks to both of you.

 

[KlausW]

I think maybe part of the issue is that you have used: 'On Error Resume Next' without switching it back on after, this means that you will not see any further errors - even if you probably should.

If you take that line out you will notice that it tries to process one more file than what is in the folder and therefore is moving to the next cell in the loop but still looking at the previous image. The reason for it processing one more file than what is there is due to the way you have set 'last_row'

As you have started 'i' at the value of 2, when your loop 'For Each sFileName In fsoFolder.Files' has completed 'i' will be greater than the count of rows with data on your 'Ark1' sheet.

THE FIX:
Remove the line: 'On Error Resume Next'
Change 'last_row = i' to 'last_row = i - 1'

Hope this helps

Both of the solution works, thanks to both of you.