VBA Macro for inserting images automatically based on a [closed] code column]

Question

VBA Macro for inserting images automatically based on a [closed] code column]

closed. this question is out of scope and is not currently accepting answers.

want to improve this question? Update the question so it's on-topic for Stack Overflow.

Closed 8 months ago .

Good afternoon,

I have a worksheet, in which it has a column with the code of the photos and in the other column next to it with spaces to insert the images. I wonder if there is any way to develop a macro, in which it recognizes the code filled next to it and look in a certain folder for the photo related to this code.

Ex:

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

2

excel vba imagem macro

Author: Kevin Valente, 2017-03-30

Source

1 answers

score 0 · Accepted Answer

If I understood right, vc has this table in a spreadsheet (in VBA I considered it to be in the range A2: B6 ) and what vc calls code refers to the name of the image file, without its extension and folder located.

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