Este fórum está sendo desativado

[Waltricke]

Bom dia Mestres!

Estou anexando uma planilha que utilizo para fazer conciliações contábeis. Todo mês são preenchidos campos manualmente nesta planilha e inseridos objetos manualmente (os objetos inseridos são relatórios contábeis salvos na rede).

Eu quero automatizar esse processo. Criei um botão e, ao clicar nele, a macro deverá fazer sozinha esses preenchimentos e inserir automaticamente o Objeto, cujo caminho de rede vai estar informado na própria planilha.

A planilha anexa contém INSTRUÇÕES DETALHADAS com prints, identificando exatamente o que preciso. Por favor me ajudem nisso.

@osvaldomp e @foxtri vcs são alguns dos feras nisso e já me ajudaram antes em outras demandas. Podem dar uma olhada?

Fico no aguardo. Quem puder ajudar, fique à vontade!

Grande abraço!

[AfonsoMira]

Boas, veja se a seguinte macro ajuda:

Código: Selecionar todos

Sub botao()

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.ActiveSheet
    Dim rngData As Range: Set rngData = ws.Range("J10")
    Dim data As Date: data = rngData.Value

    Dim caminho As String
    caminho = ws.Range("D38")
    Dim ficheiro As String
    ficheiro = "Razão da Conta " & ws.Range("J20") & ".pdf"

    Dim completo As String
    If Right(caminho, 1) = "/" Then
        completo = caminho & ficheiro
    Else
        completo = caminho & "/" & ficheiro
    End If

    strFileExists = Dir(completo)

    If strFileExists = "" Then
        MsgBox "Não foi localizado o arquivo no endereço indicado. Verifique se o arquivo foi salvo ou se está nomeado corretamente", vbOKOnly, "ARQUIVO NÃO LOCALIZADO"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    'Altera Campo 1.3

    rngData.Formula = "=EoMonth(""" & data & """, 2)"

    Application.EnableEvents = True

    rngData.Value = rngData.Value

    'Altera Campo 1.4

    Set rngData = ws.Range("J11")
    rngData = CDate(Now())


    'Altera Campo 3.2 para 3.1
    ws.Range("F28") = ws.Range("F29")
    ws.Range("F29") = ""

    'Altera Campo 3.6 para 3.5
    ws.Range("M28") = ws.Range("M29")
    ws.Range("M29") = ""

    'Elimina Qualquer Objeto dentro de D32 a G36
    Dim Sh As Shape
    With ws
        For Each Sh In .Shapes
            If Not Application.Intersect(Sh.TopLeftCell, .Range("D32:G36")) Is Nothing Then
                Sh.Delete
            End If
        Next Sh
    End With

    'Limpar informações em D32
    ws.Range("D32").ClearContents

    'Inserir Objeto

    ws.Range("D32").Select
    ws.OLEObjects.Add(Filename:= _
                      completo _
                      , Link:=False, DisplayAsIcon:=True, IconFileName:= _
                      """C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"" ""%1""" _
                      , IconIndex:=0, IconLabel:= _
                      ficheiro _
                      ).Name = "Relatório 1"
        
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
      
    MsgBox "Novo período gerado com sucesso!", vbOKOnly, "NOVO PERÍODO"
      
End Sub

Penso que tenha incluído tudo, se for necessário algo mais é só falar.

[Waltricke]

@AfonsoMira obrigado meu amigo! Mas não funcionou exatamente kkkkkk

Colei o script no Módulo 2 do editor e percebi que a ordem de execução não está conforme o sequencial que eu passei na planilha.. A inserção do objeto deve ser a última coisa que o script realiza (antes de exibir a mensagem final no MsgBox).

Ou seja, os passos 1, 2 e 3 devem acontecer antes.

Mesmo assim, ainda permanece a questão de que a parte da inserção do novo objeto não funcionou. Não localizou o objeto, mesmo eu informando o endereço e me certificando de que o arquivo está lá e no padrão desejado.

Vc pode fazer as alterações necessárias e realizar alguns testes aí, por favor?

[AfonsoMira]

Veja se assim já adiciona o Objeto:

Código: Selecionar todos

Sub botao()

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.ActiveSheet
    Dim rngData As Range: Set rngData = ws.Range("J10")
    Dim data As Date: data = rngData.Value

    Dim caminho As String
    caminho = ws.Range("D38")
    Dim ficheiro As String
    ficheiro = "Razão da Conta " & ws.Range("J20") & ".pdf"

    Dim completo As String
    If Right(caminho, 1) = "/" Then
        completo = caminho & ficheiro
    Else
        completo = caminho & "/" & ficheiro
    End If

    strFileExists = Dir(completo)

    If strFileExists = "" Then
        MsgBox "Não foi localizado o arquivo no endereço indicado. Verifique se o arquivo foi salvo ou se está nomeado corretamente", vbOKOnly, "ARQUIVO NÃO LOCALIZADO"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    'Altera Campo 1.3

    rngData.Formula = "=EoMonth(""" & data & """, 2)"

    Application.EnableEvents = True

    rngData.Value = rngData.Value

    'Altera Campo 1.4

    Set rngData = ws.Range("J11")
    rngData = CDate(Now())


    'Altera Campo 3.2 para 3.1
    ws.Range("F28") = ws.Range("F29")
    ws.Range("F29") = ""

    'Altera Campo 3.6 para 3.5
    ws.Range("M28") = ws.Range("M29")
    ws.Range("M29") = ""

    'Elimina Qualquer Objeto dentro de D32 a G36
    Dim Sh As Shape
    With ws
        For Each Sh In .Shapes
            If Not Application.Intersect(Sh.TopLeftCell, .Range("D32:G36")) Is Nothing Then
                Sh.Delete
            End If
        Next Sh
    End With

    'Limpar informações em D32
    ws.Range("D32").ClearContents

    'Inserir Objeto

    ws.Range("D32").Select
    ws.OLEObjects.Add(Filename:= _
                      completo _
                      , Link:=False, DisplayAsIcon:=True, IconFileName:= _
                      "C:\Windows\Installer\{AC76BA86-1046-1033-7760-BC15014EA700}\_PDFFile.ico" _
                      , IconIndex:=0, IconLabel:= _
                      ficheiro _
                      ).Name = "Relatório 1"
        
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
      
    MsgBox "Novo período gerado com sucesso!", vbOKOnly, "NOVO PERÍODO"
      
End Sub