Macro to automatically fetch images and play in excel

Question

Macro to automatically fetch images and play in excel

Good afternoon,

I have a spreadsheet, where I need to automatically include images. I would like to know if there is any way to elaborate a macro, in which you join the reference and the color (reference&color) and search in a certain folder the photo related to that code.

Ex:

In the macro it is possible that when you do not have a photo in the folder named with (reference&color ex: 60557000156) you have to skip it and continue inserting pictures for the next ones?

Already existing Macro: the macro that I use in other materials to search for images is this below, but it needs to be repeated for each image that I need, Previously there were a maximum of 20 images, but now for each page are at least 78 images and each excel tab has a maximum of 6 page which results in approximately 468 images, ]}

Sub Macros2()

    Call Imagem1
    Call Imagem2
    Call Imagem3
    '... 
    Call Imagem20

End Sub

Sub Imagem1()

    Range("B11").Select 'This is where picture will be inserted
    Dim picname As String
    picname = Range("A6") 'This is the picture name
    ActiveSheet.Pictures.Insert("\\storage\Img_Systextil\PROJETO LUNENDER\Fotos RPN\Inverno 2018\" & picname & ".JPG").Select  'Path to where pictures are stored
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' This resizes the picture
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    With Selection
        .Left = Range("B11").Left
        .Top = Range("B11").Top
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 150#
        .ShapeRange.Width = 150#
        .ShapeRange.Rotation = 0#
    End With

    Range("A10").Select
    Application.ScreenUpdating = True

    Exit Sub

    ErrNoPhoto:
        MsgBox "Unable to Find Photo" 'Shows message box if picture not found
        Exit Sub
        Range("B20").Select

End Sub

4

excel vba imagem automatização macro

Author: Luana Della Giustina, 2018-04-10

Source

1 answers

score 1 · Answer 1

Code

Follows the example code to accomplish this. The explanation is as a comment in the code.

Dim ref As String, codImg As String, caminho As String, caminhoImg As String
Dim corRng As Range
Dim ws As Worksheet
Dim cor

'Declara a planilha
Set ws = ThisWorkbook.Sheets("Planilha1")
'Célula Referência
ref = ws.Range("C19")
'Intervalo de códigos das cores
Set corRng = ws.Range("C13:C15")
'Diretório com arquivos
caminho = "C:\Excel\testes"

'Loop em cada célula da Range de cores
For Each cor In corRng
    'Código do arquivo de Imagem
    codImg = ref & cor
    'Caminho inteiro do arquivo
    caminhoImg = caminho & "\" & codImg & ".jpg"
    'Insere Imagens
    With ws.Pictures.Insert(caminhoImg)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 75
            .Height = 100
        End With
        'Insere no 2, que é a coluna B e linha que está o código de cor
        .Left = ws.Cells(cor.Row, 2).Left
        .Top = ws.Cells(cor.Row, 2).Top
        .Placement = 1
        .PrintObject = True
    End With
Next cor