Macro VBA for inserting images automatically based on a column of codes

Question

Good afternoon,

I have a spreadsheet, in which there is a column with the code of the photos and in the other column beside with spaces to insert the images. I wonder if there is any way to elaborate a macro, in which it recognizes the code filled next to and search in a certain folder the photo related to this code.

Ex:

In order to complement only, is it possible to add the correction of two restrictions to the formula? Next, when there is the code of the photo in the spreadsheet (ex: 1532) but in the folder there is no photo with this code, can it skip the line in which this code is described and continue inserting photos to the next ones? And the other restriction would be for him to put picture only where it is empty and skip those that already have picture.

Answer 1

If I understood correctly, you have this table in a spreadsheet (in VBA I considered it to be in the range A2:B6) and what you call code refers to the image file name without its localized extension and folder.

With these deductions I suggest the following code:

Sub Teste()

'Definir intervalo onde estão os códigos das imagens
    Dim TodosCod, Cod As Range
        Set TodosCod = ActiveSheet.Range("A2:A9")

'Definir variáveis para o procedimento de inserção de fotos
    Dim Pasta, Ext, TxtCod As String
    Dim Fig As Shape
    Dim FigJaExist As Boolean
        Pasta = "C:\Users\TashRiser\Desktop\"
        Ext = ".jpg"

'Inserir a imagem baseado no código da imagem
    For Each Cod In TodosCod
        TxtCod = Cod.Value
        FigJaExist = False

'Checar a existência do arquivo
        If Not Dir(Pasta & TxtCod & Ext) = "" Then

'Checar se há alguma foto na célula de destino
            For Each Fig In ActiveSheet.Shapes
                If Fig.TopLeftCell.Address = Cod.Offset(0, 1).Address Then FigJaExist = True
                Next Fig

'Se não houver foto na célula, inserir o arquivo
            If FigJaExist = False Then
                With ActiveSheet.Pictures.Insert(Pasta & TxtCod & Ext)
                    .Left = Cod.Offset(0, 1).Left
                    .Top = Cod.Offset(0, 1).Top
                '...caso queira determinar a largura e altura da imagem
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Width = 100
                    .ShapeRange.Height = 100
                    End With
                End If
            End If
        Next Cod

End Sub