Ir ao conteúdo
  • Cadastre-se
Regras do Clube do Hardware

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

Diego1559

Por Diego1559
em Microsoft Office e similares

 Compartilhar
Ir à solução Resolvido por Edson Luiz Branco,

Posts recomendados

Diego1559
 

Diego1559

Postado
Postado

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

 

1651198843_2021-04-03(2).png.191ffedb3a62d3476a711704ba2a1d4c.png

Link para o comentário
Compartilhar em outros sites
  • Solução
Edson Luiz Branco
 

Edson Luiz Branco

Postado
  • Solução
Postado

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

 

  • Obrigado 1
Link para o comentário
Compartilhar em outros sites
Diego1559
 

Diego1559

Postado
  • Autor
Postado

 

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

Link para o comentário
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisa ser um usuário para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora
 Compartilhar
Ir à lista de tópicos

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

Mais

×
×
  • Criar novo...

 

GRÁTIS: ebook Redes Wi-Fi – 2ª Edição

EBOOK GRÁTIS!

CLIQUE AQUI E BAIXE AGORA MESMO!