Este fórum está sendo desativado

Depois de 9 anos, este fórum será desativado. Mas calma.... estamos migrando para uma comunidade no DISCORD. Junte-se a nós.

ENTRAR PARA DISCORD

Tópicos relacionados a códigos VBA, gravação de macros, etc.
  • Avatar do usuário
  • Avatar do usuário
#70078
Boa tarde

Pedindo ajuda para tentar melhorar código gerado pelo gravador de macros, então é assim:

Fiz a macro em baixo com recurso ao gravador de macros, sendo que ela serve para copiar um range de uma tab para outra tab, de forma a ficar dinâmico, ou seja, como se trata de um calendário sempre que atualizo o mês, a imagem é atualizada na tab principal.
Fiz os arranjos possíveis dentro dos meus conhecimentos, mas continua a ter "Activate", "Select", "Selection" que não consigo "apagar".
Não sei se é por ignorância minha ou se não dá mesmo para melhorar a macro.
Peço pois ajuda para se possível melhorar e simplificar esta macro:
Código: Selecionar todos
Sub CopyCalendario()

    WsCAL.Range("M17:U24").Copy
    WsT.Range("F1").Activate
    ActiveSheet.Pictures.Paste(Link:=True).Select
    With Selection
        .Formula = "=CALENDARIO!$M$17:$U$24"
        .ShapeRange.Name = "CMensal"
        .ShapeRange.Fill.visible = msoFalse
        .ShapeRange.Line.visible = msoFalse
        .Left = 450
        .Top = 2.5
        .Width = 187.313
        .Height = 178.988
        .OnAction = "....NOME da MACRO AQUI...."
    End With
    Application.CutCopyMode = False
End Sub
Outra coisa que não estou conseguindo é depois de copiar para a tab principal desseleccionar a Shape, sem ter que selecionar uma determinada célula p.ex., é possível?

Obrigado
Jorge
Editado pela última vez por JCabral em 14 Abr 2022 às 06:59, em um total de 1 vez.
#70247
Código: Selecionar todos
Private Sub CopyCalendario()
    Delete_CAL

    WsCAL.Range("M17:U24").Copy
    
    With ActiveSheet
        .Range("F1").Activate
        
        With .Pictures.Paste(Link:=True)
            .Formula = "=CALENDARIO!$M$17:$U$24"
            
            With .ShapeRange
                .Name = "CMensal"
                .Fill.Visible = msoFalse
                .Line.Visible = msoFalse
            End With
            
            .Left = 450
            .Top = 2.5
            .Width = 187.313
            .Height = 178.988
'           .OnAction = "....NOME da MACRO AQUI...."
        End With
    End With
    Application.CutCopyMode = False
End Sub

Private Sub Delete_CAL()
    On Error Resume Next
    ActiveSheet.Shapes.Range("CMensal").Delete
    On Error GoTo 0
End Sub
#70249
Sim, claro. Onde está Activesheet você substitui pelo codename da planilha onde você deseja copiar.
#70261
@babdallas,

Dá-me erro em
Código: Selecionar todos
.Range("F1").Activate
O que estou a fazer de errado?

Código completo:
Código: Selecionar todos
Private Sub CopyCalendario_babdallas()
    Delete_CAL_babdallas

    WsCAL.Range("M17:U24").Copy
    
    With WsT
        .Range("F1").Activate
        
        With .Pictures.Paste(Link:=True)
            .Formula = "=CALENDARIO!$M$17:$U$24"
            
            With .ShapeRange
                .Name = "CMensal"
                .Fill.Visible = msoFalse
                .Line.Visible = msoFalse
            End With
            
            .Left = 450
            .Top = 2.5
            .Width = 187.313
            .Height = 178.988
'           .OnAction = "....NOME da MACRO AQUI...."
        End With
    End With
    Application.CutCopyMode = False
End Sub

Private Sub Delete_CAL_babdallas()
    On Error Resume Next
    WsT.Shapes.Range("CMensal").Delete
    On Error GoTo 0
End Sub
#70265
Olá, @JCabral .
Veja se ajuda.
Código: Selecionar todos
Sub ReplicaFormataCalendário()
 Dim ws As Worksheet
 Application.ScreenUpdating = False
 Set ws = ActiveSheet
 Delete_CAL
 Sheets("CALENDARIO").Range("M17:U24").CopyPicture xlScreen, xlPicture
 With Sheets("PRINCIPAL")
  .Range("B2").PasteSpecial
  .Pictures(Worksheets(.Name).Pictures.Count).Name = "CMensal"
   With .Shapes("CMensal")
    .DrawingObject.Formula = "=CALENDARIO!$M$17:$U$24"
    .Left = 450
    .Top = 2.5
    .Width = 187.313
    .Height = 178.988
' '  .OnAction = "....NOME da MACRO AQUI...."
   End With
  .Activate: .[M7].Activate
 End With
 ws.Activate
End Sub


#70267
Código: Selecionar todos
Private Sub CopyCalendario()
    Delete_CAL

    WsCAL.Range("M17:U24").Copy
    
    With WsT.Pictures.Paste(Link:=True)
        .Formula = "=CALENDARIO!$M$17:$U$24"
        
        With .ShapeRange
            .Name = "CMensal"
            .Fill.Visible = msoFalse
            .Line.Visible = msoFalse
        End With
        
        .Left = 450
        .Top = 2.5
        .Width = 187.313
        .Height = 178.988
'           .OnAction = "....NOME da MACRO AQUI...."
    End With
    Application.CutCopyMode = False
End Sub

Private Sub Delete_CAL()
    On Error Resume Next
    WsT.Shapes.Range("CMensal").Delete
    On Error GoTo 0
End Sub

=SE(MÊS(A1)<7;"1º sem&a[…]

Bom Dia Senhores. Tenho uma macro que preciso dei[…]

Free relationships without drama and obligations. […]

Girar Imagem e Zoom

Boa noite Teria alguma forma de dar um "[…]

Valeu. Muito Obrigado!!!!!!!!

Pessoal, Ao clicar no botão Copiar (Guia C[…]

Procv com serro em vba

Resolvido

Bom dia, pessoal! com a data de nascimento e data […]

Estamos migrando para uma comunidade no Discord