VBA macro for automatically inserting images based on a code column

Question

VBA macro for automatically inserting images based on a code column

Navigation

#1 by (0 votes)

2

Good afternoon,

I have a spreadsheet, which has a column with the code of the photos and the other column next to it with spaces to insert the images. I would like to know if there is any way to elaborate a macro, in which it recognizes the code next to it and searches in a certain folder the photo related to this code.

Ex:

In order to only complement, is it possible to add in the formula the correction of 2 constraints? Next, when there is the code of the photo in the worksheet (ex: 1532) but in the folder there is no photo with this code, does he have to 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 a photo only where it is empty and skip those that already have a photo.

macro imagem excel vba

asked by anonymous 30.03.2017 / 18:58

1 answer

Description of Files and Directories in GitHub [closed] Row Logic - Python

score 0 · Accepted Answer

If I understood correctly, you have this table in a worksheet (in VBA I considered it to be in the range A2: B6 ) and what you call code refers to the file name of the image, without its extension and located 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