Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
VBA - Deletar image...
 
Notifications
Clear all

VBA - Deletar imagens de células específicas

 
2024 - VBA & Macros
Post Recente por Caique.Z 9 anos atrás
7 Posts
4 Usuários
0 Reactions
7,245 Visualizações
RSS
 Maycon
(@maycon)
Posts: 17
Eminent Member
Topic starter
 

Boa Dia,

Volta eu mais uma vez com uma dúvida que esta queimando minha cabeça...
Em minha planilha de relatório, são inseridas informações para extração de informações de um site na internet porém, junto com ele são copiadas também algumas imagens.
Preciso de uma macro para apagar essas imagens só que... não posso usar uma macro de apagar todas as imagens, porque não uso botões normais para linkar as macros, uso algumas imagens servindo de botões.
Quando eu utilizava botões simples, usava esses dois tipos de macros porém, como uso botões em forma de imagens, não posso usar essas macros porque irão apagar todas as imagens da planilha!!!
Outra coisa, não posso pagar pelo nome da imagem porque são inseridas mais de 100 imagens em cada inserção de dados na planilha.

ActiveSheet.Shapes.SelectAll
Selection.Delete

e

Sub DeletePIcture()
Dim jpg As Object
Dim sh As Worksheet
For Each sh In Worksheets
For Each jpg In sh.Pictures
jpg.Delete
Next
Next
End Sub

Então é isso que preciso de ajuda, uma macro para eu apagar as imagens das células que eu selecionar.
Exemplo: Serão apagadas todas as imagens que estiverem nessa condição (B43:N1042)

Desde já, muito obrigado pela atenção!!!

Maycon Frazão

 
Postado : 12/02/2014 1:51 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia Maycon

Movi teu tópico para o subfórum adequado a tua dúvida, que é VBA & Macros.

No início vou deixar mostrando nos 2 subfóruns para você se localizar.

At.te

Patropi - Moderador

 
Postado : 12/02/2014 5:25 am
 Alminen
(@alminen)
Posts: 77
Trusted Member
 
Sub RemoverImg()
On Error Resume Next
Dim img As Shape, cl1 As String, cl2 As String

cl1 = Application.InputBox(prompt:="Célula 1:", Type:=8)
cl2 = Application.InputBox(prompt:="Célula 2:", Type:=8)


For Each img In ActiveSheet.Shapes
    If Not Application.Intersect(img.TopLeftCell, ActiveSheet.Range(cl1 & ":" & cl2)) Is Nothing Then
        img.Delete
    End If
Next

End Sub

No caso, o código te dá dois prompts pedindo a primeira célula e a última célula (você pode digitar, ou selecionar a célula de fato).

 
Postado : 12/02/2014 8:08 am
 Maycon
(@maycon)
Posts: 17
Eminent Member
Topic starter
 

Boa Tarde,

Não deu muito certo...
A fórmula habilita uma caixa para eu digitar as duas células, minha intenção seria apagar automaticamente ao clicar no botão. e outra coisa, ela apagou todas as imagens da planilha, mesmo eu selecionando as células específicas.

Pode ajudar?

 
Postado : 12/02/2014 9:09 am
 Maycon
(@maycon)
Posts: 17
Eminent Member
Topic starter
 

Fiz um novo teste com a fórmula e realmente não deu certo, todas as imagens da pasta são apagadas usando a fórmula acima.
:(

 
Postado : 12/02/2014 9:20 am
 Alminen
(@alminen)
Posts: 77
Trusted Member
 
Sub RemoverImg()
On Error Resume Next
Dim img As Shape

For Each img In ActiveSheet.Shapes
    If Not Application.Intersect(img.TopLeftCell, ActiveSheet.Range("B43:N1042")) Is Nothing Then
        img.Delete
    End If
Next
End Sub

Coloquei um range fixo, conforme você propôs ali em cima (B43:N1042). Essa fórmula apaga TODO tipo de de imagem/desenho/shape etc. da planilha que esteja ativa, e dentro deste intervalo pré-definido. O que acho curioso é você ter dito que apagou todas as imagens de todas as suas planilhas... Aqui foi só da planilha ativa.

 
Postado : 13/02/2014 7:35 am
 Caique.Z
(@caique-z)
Posts: 0
New Member
 

Bom dia Pessoal, a principio a macro funcionava tudo certo, depois de pouco tempo funcionando começa dar o erro "1004".
O erro acontece justamente onde aparece em vermelho, se eu copiar o codigo e colocar novamente a macro volta a rodar normalmente.
Porém preciso que esse erro não aconteça. Pode me ajudar ???

Sub Apagar_Tudo()
'
' Apagar_Tudo Macro
'
For Each img In ActiveSheet.Shapes
If Not Application.Intersect(img.TopLeftCell, ActiveSheet.Range("C41:AL41")) Is Nothing Then
img.Delete
End If

Next
Application.ScreenUpdating = False 'Desabilita atualização de tela
ActiveWorkbook.RefreshAll
Sheets("Relatório D-0").Activate
ActiveSheet.AutoFilter.ApplyFilter
Range("H1:S1").Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Régua").Activate
Range("C41").Activate
ActiveSheet.Pictures.Paste.Select
Sheets("Relatório D-1").Activate
Application.CutCopyMode = False
ActiveSheet.AutoFilter.ApplyFilter
Range("H1:S1").Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Régua").Activate
Range("AL41").Activate
ActiveSheet.Pictures.Paste.Select
Application.CutCopyMode = False 'Limpa a área de transferência

ActiveWindow.ScrollRow = 6

End Sub

 
Postado : 24/03/2016 6:10 am
Forum Jump:
  Tópico Anterior
Próximo Tópico