Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
VBA para Copiar e C...
 
Notifications
Clear all

VBA para Copiar e Colar imagem de uma planilha para outra

 
2024 - VBA & Macros
Post Recente por Necron 11 anos atrás
4 Posts
2 Usuários
0 Reactions
1,393 Visualizações
RSS
 Necron
(@necron)
Posts: 117
Estimable Member
Topic starter
 

Ola!

Gostaria de uma ajudinha.

Tenho uma planilha onde na coluna "A" tem diversos valores numéricos, e gostaria que uma macro copiasse a Picture na "Plan2" e colasse nas células da coluna "A" seguindo esse critérios:

* Valor de: 0 a 10 - Copiar Picture 1 e colar no centro das celulas
* Valor de: 10,1 a 20 - Copiar Picture 2 e colar no centro das celulas
* Valor de : 20,1 a 999 - Copiar Picture 2 e colar no centro das celulas

Planilha:

Fui Util? Click na "Mãozinha" ali do lado >>>> e agradeça.

 
Postado : 10/01/2014 12:11 pm
 Necron
(@necron)
Posts: 117
Estimable Member
Topic starter
 

Imagino que o codigo seja algo parecido com isso, mas não consigo fazer funcionar:

Sub Semaforo()

    Dim X As Long
    Dim lastrow As Long
     
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For X = lastrow To 1 Step -1
        If Cells(X, 1).Value <= "0" Then
            Sheets("Plan2").Select
            ActiveSheet.Shapes.Range(Array("Picture 1")).Select
            Selection.Copy
            Sheets("Plan1").Select
                With Cells(X, 1)
                    .Selection.Paste
                    .Selection.ShapeRange.IncrementLeft 8.5
                    .Selection.ShapeRange.IncrementTop 5.5
                End With
        End If
    Next X

End Sub

Fui Util? Click na "Mãozinha" ali do lado >>>> e agradeça.

 
Postado : 10/01/2014 1:16 pm
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Talvez assim?

Sub Semaforo()

    Dim X As Long
    Dim lastrow As Long
     
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For X = lastrow To 1 Step -1
        If Cells(X, 1).Value <= "0" Then
           Sheets("Plan2").Shapes.Range(Array("Picture 1")).Copy
            ActiveSheet.Paste
                With Selection
                    .Top = Cells(X, 1).Top
                    .Left = Cells(X, 1).Left
                End With
        End If
    Next X

End Sub

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 11/01/2014 7:36 am
 Necron
(@necron)
Posts: 117
Estimable Member
Topic starter
 

Obrigado!

Consegui fazer a adaptação que queria com sua ajuda.

Fui Util? Click na "Mãozinha" ali do lado >>>> e agradeça.

 
Postado : 20/01/2014 7:21 am
Forum Jump:
  Tópico Anterior
Próximo Tópico