Excel Abrir varios arquivos .xlsm e inserir uma imagem

[thiago.alves22]

Boa tarde senhores, senhoras e reptlianos.

 

Imagina esse cenário: preciso inserir uma imagem especifica, em uma worksheet especifica em todas as planilhas que estão em uma pasta no windows(é a mesma imagem para todas e todas essas planilhas possuem essa mesma worksheet).

 

alguem poderia me ajudar com uma macro pra isso? 

[AfonsoMira]

Poderia criar um loop para abrir ficheiro a ficheiro e inserir a imagem.
Qual o caminho da sua pasta?

[thiago.alves22]

@AfonsoMira a pasta que estão os arquivos Excel é a mesma, todos eles estão lá mas com nomes diferentes

[AfonsoMira]

@thiago.alves22 Certo. E essa pasta qual o nome dela e onde ela se encontra?
Faz o seguinte:

1. Clique com o botão direito sobre a pasta
2. Vá em Propriedades
3. Depois na aba Segurança
4. Onde está "Nome do Objeto" copie o que está em frente e mande para aqui

Ps. Esse é o caminho da pasta.

[thiago.alves22]

@AfonsoMira C:\Users\thiago.vasconcelos\OneDrive - Axess AS\Desktop\Axess\Axess\Modelo

 

No meu caso a pasta é essa. Teria algum comando para abrir os arquivos um a um da pasta em que o arquivo excel esta independente do endereço?

[AfonsoMira]

@thiago.alves22 Qual o nome da worksheet?
Qual o nome da imagem? E o caminho dela? 

[thiago.alves22]

@AfonsoMira

nome da worksheet: SegundaPagina2Fotos

nome da imagem com o caminho: C:\Users\thiago.vasconcelos\OneDrive - Axess AS\Desktop\Axess\Axess\Assinatura Lincon\Assinaturas\Assinatura Lincon Daquilla.jpeg

 

[AfonsoMira]

@thiago.alves22 Qual a célula que deseja colocar a imagem?

[thiago.alves22]

@AfonsoMira Q59

[AfonsoMira]

@thiago.alves22 Então fiz aqui dois códigos:

 

Um com o caminho da pasta e da imagem já dentro do código:

Sub loopFoto()

    Dim MinhaPasta As String, MeuFicheiro As String, MinhaImagem As String
    
    MinhaPasta = "C:\Users\thiago.vasconcelos\OneDrive - Axess AS\Desktop\Axess\Axess\Modelo"
    MinhaImagem = "C:\Users\thiago.vasconcelos\OneDrive - Axess AS\Desktop\Axess\Axess\Assinatura Lincon\Assinaturas\Assinatura Lincon Daquilla.jpeg"
    
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    MeuFicheiro = Dir(MinhaPasta & "\", vbReadOnly)
    
    Do While MeuFicheiro <> ""
        DoEvents
        On Error GoTo 0
        Workbooks.Open Filename:=MinhaPasta & "\" & MeuFicheiro, UpdateLinks:=False
        'Aqui vai o nome da WorkSheet
        Sheets("SegundaPagina2Fotos").Select
        
        With ActiveSheet.Pictures.Insert(MinhaImagem)
            With .ShapeRange
                .LockAspectRatio = msoTrue
                .Width = 75 'Alterar tamanho
                .Height = 100 'Alterar tamanho
            End With
            .Left = ActiveSheet.Range("Q59").Left
            .Top = ActiveSheet.Range("Q59").Top
            .Placement = 1
            .PrintObject = True
        End With
        
0
        Workbooks(MeuFicheiro).Close SaveChanges:=True
        MeuFicheiro = Dir
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationManual

End Sub

 

Outro com a possibilidade de escolher a pasta e a imagem:

Sub loopFoto()

    Dim MinhaPasta As String, MeuFicheiro As String, MinhaImagem As String
    
    MsgBox "Selecione a pasta!", vbOKOnly
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        MinhaPasta = .SelectedItems(1)
        Err.Clear
    End With
    
    MsgBox "Selecione a imagem!", vbOKOnly
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "JPEG File Interchange Format", "*.JPEG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "Tag Image File Format", "*.TIFF"
        .Filters.Add "All Pictures", "*.*"
        .AllowMultiSelect = False
        .Show
        MinhaImagem = .SelectedItems(1)
        Err.Clear
    End With
    
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    MeuFicheiro = Dir(MinhaPasta & "\", vbReadOnly)
    
    Do While MeuFicheiro <> ""
        DoEvents
        On Error GoTo 0
        Workbooks.Open Filename:=MinhaPasta & "\" & MeuFicheiro, UpdateLinks:=False
        Sheets("SegundaPagina2Fotos").Select
        
        With ActiveSheet.Pictures.Insert(MinhaImagem)
            With .ShapeRange
                .LockAspectRatio = msoTrue
                .Width = 75
                .Height = 100
            End With
            .Left = ActiveSheet.Range("Q59").Left
            .Top = ActiveSheet.Range("Q59").Top
            .Placement = 1
            .PrintObject = True
        End With
        
0
        Workbooks(MeuFicheiro).Close SaveChanges:=True
        MeuFicheiro = Dir
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationManual

End Sub

 

Espero que lhe ajude!

Ps. Certifique-se que dentro da pasta apenas existem ficheiros Excel caso contrário vai causar erro.

[thiago.alves22]

@AfonsoMira uma duvida, a worksheet(SegundaPagina2Fotos) precisa estar visivel pra imagem ser inserida?

 

o codigo funcionou perfeitamente pra quando a worksheet esta visivel, mas quando ela ta ocultada nao funcionou

[AfonsoMira]

@thiago.alves22 Sim precisa.

Troque a linha de código:  

Sheets("SegundaPagina2Fotos").Select

 Por:

Sheets("SegundaPagina2Fotos").visible = true
Sheets("SegundaPagina2Fotos").Select

 

O que vai fazer é caso a worksheet(SegundaPagina2Fotos) não esteja visível ele vai tornar visível.

[thiago.alves22]

@AfonsoMira, quando boto o codigo pra rodar ele fica parado na tela do vba como se nao tivesse codigo nenhum.

[AfonsoMira]

@thiago.alves22 Colocou o código em que ficheiro? Tem esse ficheiro na mesma pasta?
Caso tenha crie um ficheiro novo em uma pasta diferente, para não correr o risco de ele fechar a macro.

[thiago.alves22]

@AfonsoMira criei um arquivo novo em outra pasta e coloquei o codigo pra rodar, ele agr roda tudo mas nada acontece.

[AfonsoMira]

@thiago.alves22 Está a utilizar qual código? O primeiro que mandei ou o segundo?

[thiago.alves22]

@AfonsoMira O primeiro com o if inserido

[AfonsoMira]

@thiago.alves22 Ok eu atualizei esse código, pode ser que não tenha reparado.

Troque esse IF

If Sheets("SegundaPagina2Fotos").visible = false Then
  Sheets("SegundaPagina2Fotos").visible = true
  Sheets("SegundaPagina2Fotos").Select
  Sheets("SegundaPagina2Fotos").visible = false
Else
	Sheets("SegundaPagina2Fotos").Select
End if

por:

Sheets("SegundaPagina2Fotos").visible = true
Sheets("SegundaPagina2Fotos").Select

 

 

E veja se resolve.

 

Experimente também utilizar o segundo código.

[thiago.alves22]

@AfonsoMira eu coloquei essa linha que você propos por ultimo no lugar do if e ao fim da inserção de imagem eu coloquei pra ocultar de novo, funcionou como esperado. 

apesar do primeiro codigo nao funcionar, o segundo atende muito mais a situação porque a assinatura que pretendo inserir varia, valeu mesmo! a principio acho que foi resolvido, qualquer coisa eu marco voce de novo! tyty

[AfonsoMira]

@thiago.alves22 Foi um prazer ajudar!  
Mais alguma dúvida é só marcar.
 

Não se esqueça de colocar o tópico como resolvido e deixar o gostei como forma de agradecimento!

[thiago.alves22]

@AfonsoMira uma duvida, porque tem um 0 embaixo do ultimo With?

[AfonsoMira]

@thiago.alves22

 

É uma das formas de tratamento de erros.

 

É por conta dessa linha de código:
 

On Error GoTo 0

 

Caso ocorra um erro entre ela e o "0" , ele salta todas as linhas desde o erro e recomeça após o "0".

 

Não sei se me fiz entender.

[thiago.alves22]

@AfonsoMira entendi, perfeito.