Ir ao conteúdo
Regras do Clube do Hardware

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

Jorge Carneiro

Por Jorge Carneiro
em Microsoft Office e similares

 Compartilhar

Posts recomendados

Jorge Carneiro
 

Jorge Carneiro

Postado
Postado

Muito boa tarde, Edson!

Adaptar o código abaixo para 6 imagens por linha em 6 linhas.

Já tentei alterar os códigos das linhas e das colunas, porém não consigo adicionar mais do que 2 imagens por linha.

Basicamente gostaria de perceber em que parte do código  consta a mudança de linha e o número de imagens por linha.

Grato por toda a ajuda que possa disponibilizar!

Cumprimentos. 

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

fotos teste - Excel.jpg

Basole
 

Basole

Postado
Postado

@Jorge Carneiro segue sugestão de acordo com as posições, a imagem da aba, postada

  

Sub Inserir6ImgPorColuna6Linhas()
    Dim ArqSel   As String
    Dim Celula   As String
    Dim i        As Long
    Dim n        As Long
    Dim j        As Long
    Dim myAr     As Variant
    Dim dv       As Double
    Dim ct       As Integer
    Dim num      As Double
    Dim msg      As String
    Dim MyFolder As Object
    Dim FolderSelected 
   
     msg = "Por favor, selecione a PASTA que contem os arq. de imagens"
 Set MyFolder = Application.FileDialog(msoFileDialogFolderPicker)
    With MyFolder
    .Title = msg
    .AllowMultiSelect = False
    If .Show <> -1 Then
    Exit Sub
    End If
    FolderSelected = .SelectedItems(1)
      If Not FolderSelected <> False Then
             MsgBox msg, 64, "Aviso"
           Exit Sub
       End If
    End With
        ArqSel = VBA.Dir(FolderSelected & "\")
    With ActiveSheet
        On Error GoTo Fin:
       Application.ScreenUpdating = False
        n = 1
        ReDim myAr(n To 32)
        For i = 3 To 18 Step 3
        For j = 1 To 16 Step 3
        If n > 32 Then Exit For
        myAr(n) = .Cells(i, j).Address
        n = n + 1
        Next
        Next
        i = 1
        Do While Val(ct) < UBound(myAr)
          Celula = VBA.Replace(myAr(i), "$", "")
         .Shapes.AddPicture FolderSelected & "\" & ArqSel, False, True, .Range(Celula).Left, _
                                                        .Range(Celula).Top, _
                                                        .Range(Celula).Width + _
                                                        .Range(Celula).Offset(, 1).Width, _
                                                        .Range(Celula).Height
            ArqSel = VBA.Dir()
            i = i + 1
            ct = ct + 1
            dv = ct / 16
            num = dv * 11
            ' (abaixo ): barra de status
            Application.StatusBar = "Aguarde o Processamento:=  Inserind.... " & _
                                    ct & " de " & UBound(myAr) & "  *.Jpg ......: " & _
                                    "( " & VBA.Format(ct / UBound(myAr), "Percent") & " ) " & _
                                    Application.Rept(VBA.ChrW(9632), num)
            DoEvents
        Loop
  End With
Fin:
    Application.ScreenUpdating = True
    If VBA.Val(ct) < VBA.Val(1) Then
        MsgBox ct & " imagens foram inseridas!", 0, "Sucesso!"
    Else
        MsgBox ct & " imagens foram inseridas!", 0, "Sucesso!"
    End If
    Application.StatusBar = False

End Sub

 

 

 

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...

LANÇAMENTO!

eletronica2025-popup.jpg


CLIQUE AQUI E BAIXE AGORA MESMO!