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,400 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

(@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