Excel Adaptar código VBA de planilha com relatório de fotos

Diego1559 · 3 de abril de 2021

Olá pessoal,

Preciso da ajuda de vcs. Sou um curioso nesta área, e estou encontrando uma certa dificuldade para adaptar um código de VBA de uma planilha, para a planilha que uso.

Basicamente, no código que achei, ele insere 22 fotos sendo 3 por linha. Gostaria que ficassem apenas 2 por linha, conforme a foto da planilha que uso. E se possível, que elas se ajustassem automaticamente ao tamanho das células mescladas de cada espaço da Foto01, Foto02...Foto06. Já tentei modificar, porém, sempre fica uma foto para fora da minha planilha.

O código:

Sub Carregar_AutoImagens_Passagem_Serviço_Gocil()

Dim Pict
Dim ImgFileFormat As String
Dim Celula As String
Celula = "A95" ' celula que será inserido a imagem
ImgFileFormat = "Image Files JPEG (*.jpeg),*.jpeg,Image Files JPG (*.jpg),*.jpg, Image Files PNG (*.png),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"

'Pict = Application.GetOpenFilename(ImgFileFormat, False, False, MultiSelect:=True)

Pict = Application.GetOpenFilename(ImgFileFormat, False, False, False, True)

'If Pict = False Then End

If IsArray(Pict) Then 'IF ARRAY

If UBound(Pict) <= 22 Then 'IF I

j = 1

For i = LBound(Pict) To UBound(Pict) 'FOR I

Select Case i 'Cobertura de 22 imagens

Case 1 To 3
'IMAGEM: largura = 4 colunas; altura= 11 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "95"


Case 4 To 6
If Mid(Celula, 1, 1) = "M" Then
j = 1
Celula = Chr(64 + j) & "107"
End If
'IMAGEM: largura = 6 colunas; altura= 11 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "107"


Case 7 To 9
If Mid(Celula, 1, 1) = "M" Then
j = 1
Celula = Chr(64 + j) & "119"
End If
'IMAGEM: largura = 4 colunas; altura= 11 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "119"


Case 10 To 12
If Mid(Celula, 1, 1) = "M" Then
j = 1
Celula = Chr(64 + j) & "131"
End If
'IMAGEM: largura = 4 colunas; altura= 11 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "131"


Case 13 To 15
If Mid(Celula, 1, 1) = "M" Then
j = 1
Celula = Chr(64 + j) & "143"
End If
'IMAGEM: largura = 4 colunas; altura= 11 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "143"


Case 16 To 18
If Mid(Celula, 1, 1) = "M" Then
j = 1
Celula = Chr(64 + j) & "155"
End If
'IMAGEM: largura = 4 colunas; altura= 11 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "155"


Case 19 To 21
If Mid(Celula, 1, 1) = "M" Then
j = 1
Celula = Chr(64 + j) & "167"
End If
'IMAGEM: largura = 4 colunas; altura= 11 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "167"

End Select

Next i 'FOR I

Else 'IF I

MsgBox "Selecionar apenas 22 imagens"


End

End If 'IF I

End If 'IF ARRAY
End Sub

Minha tentativa em alterar o código para a minha planilha:

Sub Carregar_AutoImagens_Passagem_Serviço_Gocil()

Dim Pict
Dim ImgFileFormat As String
Dim Celula As String
Celula = "A8" ' celula que será inserido a imagem
ImgFileFormat = "Image Files JPEG (*.jpeg),*.jpeg,Image Files JPG (*.jpg),*.jpg, Image Files PNG (*.png),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"

'Pict = Application.GetOpenFilename(ImgFileFormat, False, False, MultiSelect:=True)

Pict = Application.GetOpenFilename(ImgFileFormat, False, False, False, True)

'If Pict = False Then End

If IsArray(Pict) Then 'IF ARRAY

If UBound(Pict) <= 6 Then 'IF I

j = 1

For i = LBound(Pict) To UBound(Pict) 'FOR I

Select Case i 'Cobertura de 6 imagens

Case 1 To 2
'IMAGEM: largura = 4 colunas; altura= 17 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "8"


Case 3 To 4
If Mid(Celula, 1, 1) = "M" Then
j = 1
Celula = Chr(64 + j) & "29"
End If
'IMAGEM: largura = 4 colunas; altura= 17 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "29"


Case 5 To 6
If Mid(Celula, 1, 1) = "M" Then
j = 1
Celula = Chr(64 + j) & "49"
End If
'IMAGEM: largura = 4 colunas; altura= 17 linhas
Application.ActiveSheet.Shapes.AddPicture Pict(i), False, True, Range(Celula).Left, _
Range(Celula).Top, Range(Celula).Width * 4, Range(Celula).Height * 11

j = j + 4
Celula = Chr(64 + j) & "49"

End Select

Next i 'FOR I

Else 'IF I

MsgBox "Selecionar apenas 6 imagens"


End

End If 'IF I

End If 'IF ARRAY
End Sub

Edson Luiz Branco · 8 de abril de 2021

Bem vindo ao fórum, @Diego1559

Provavelmente seu tópico ficou sem respostas até o momento por ter faltado anexar um modelo em Excel junto com sua dúvida.

Alterei seu código eliminando algumas partes e acrescentando outras. Teste em seu modelo e nos dê retorno, ok?:

Sub Carregar_Pares_Imagens()
    Dim Pict As Variant, ImgFileFormat As String, rgMescladas As Range, i As Long
    ImgFileFormat = "Image Files JPEG (*.jpeg),*.jpeg,Image Files JPG (*.jpg),*.jpg, Image Files PNG (*.png),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"
    Pict = Application.GetOpenFilename(ImgFileFormat, False, False, False, True)
    If IsArray(Pict) Then
      If UBound(Pict) > 6 Then
          MsgBox "Selecionar apenas 6 imagens"
          Exit Sub
      End If
      For i = 1 To UBound(Pict)
        Set rgMescladas = ActiveSheet.Cells(RowIndex:=Array(8, 29, 49)((i - 1) \ 2), _
                                         ColumnIndex:=Array("A", "E")((i - 1) Mod 2))
        If rgMescladas.MergeCells Then Set rgMescladas = rgMescladas.MergeArea
        rgMescladas.Worksheet.Shapes.AddPicture Filename:=Pict(i), _
                                                LinkToFile:=msoFalse, _
                                                SaveWithDocument:=msoTrue, _
                                                Left:=rgMescladas.Left, _
                                                Top:=rgMescladas.Top, _
                                                Width:=rgMescladas.Width, _
                                                Height:=rgMescladas.Height
      Next i
    End If
End Sub

Diego1559 · 8 de abril de 2021

2 horas atrás, Edson Luiz Branco disse:

Bem vindo ao fórum, @Diego1559

Provavelmente seu tópico ficou sem respostas até o momento por ter faltado anexar um modelo em Excel junto com sua dúvida.

Alterei seu código eliminando algumas partes e acrescentando outras. Teste em seu modelo e nos dê retorno, ok?:



Sub Carregar_Pares_Imagens()
    Dim Pict As Variant, ImgFileFormat As String, rgMescladas As Range, i As Long
    ImgFileFormat = "Image Files JPEG (*.jpeg),*.jpeg,Image Files JPG (*.jpg),*.jpg, Image Files PNG (*.png),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"
    Pict = Application.GetOpenFilename(ImgFileFormat, False, False, False, True)
    If IsArray(Pict) Then
      If UBound(Pict) > 6 Then
          MsgBox "Selecionar apenas 6 imagens"
          Exit Sub
      End If
      For i = 1 To UBound(Pict)
        Set rgMescladas = ActiveSheet.Cells(RowIndex:=Array(8, 29, 49)((i - 1) \ 2), _
                                         ColumnIndex:=Array("A", "E")((i - 1) Mod 2))
        If rgMescladas.MergeCells Then Set rgMescladas = rgMescladas.MergeArea
        rgMescladas.Worksheet.Shapes.AddPicture Filename:=Pict(i), _
                                                LinkToFile:=msoFalse, _
                                                SaveWithDocument:=msoTrue, _
                                                Left:=rgMescladas.Left, _
                                                Top:=rgMescladas.Top, _
                                                Width:=rgMescladas.Width, _
                                                Height:=rgMescladas.Height
      Next i
    End If
End Sub

Ficou da forma que preciso.Muito obrigado .Na próxima me atentarei pra anexar o excel