Notifications

Clear all

Executar macro em loop

2024 - VBA & Macros

Post Recente por romanholi 8 anos atrás

7 Posts

4 Usuários

0 Reactions

1,523 Visualizações

RSS

romanholi

(@romanholi)

Posts: 177

Estimable Member

Topic starter

Amigos, boa tarde!

Fiz uma macro para imprimir alguns relatório com base no duplo clik que dou numa célula:

Como funciona:

Quando eu dou um duplo clik na coluna 4 que é o RE do meu funcionário, ele armazena as variáveis:
RE
Setor
Tipo (Vai ser mecanica ou eletrica)
Responsavel
Planilha (Nessa coluna tem o nome da planilha que é para imprimir)

Daí depois que eu dou o duplo cick e armazena esses dados ela abre um formulário para eu escolher a data inicial e a final que vai alimentar a capa que antecederá a planilha de inspeção que deverá ser impressa com base na variável Planilha.

Em resumo.

A macro funciona perfeitamente. Só que eu tenho 40 funcionários e eu tenho que dar duplo clique em todos para executar!

Queria que essa macro abaixo ao invés de ser no duplo click executasse para cada linha da coluna 4 partindo da linha 5.

Executar a mesma macro, exatamente assim, só que em loop para todas as linha da coluna 4 partindo da linha 5 (E claro, identificando a última linha preenchida da coluna 4) para não ter perigo de executar as linhas em branco.

Não consigo enviar-lhes o arquivo, pois são muitas inspeções. Se puderem me ajudar visualizando a macro abaixo. Agradeço-lhes muito!

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


If Target.Column = 4 Then


Dim Nome_Celula As String

 Nome_Celula = ActiveCell.Value
 Setor = ActiveCell.Offset(0, -1).Value
 Tipo = ActiveCell.Offset(0, -2).Value
 Responsavel = ActiveCell.Offset(0, 1).Value
 Planilha = ActiveCell.Offset(0, 5).Value
 


    Form_Data.Show
     
    

    Sheets("Capa").Select

    Sheets("Capa").Range("A33") = Setor
    Sheets("Capa").Range("A35") = Tipo
    Sheets("Capa").Range("C54") = Nome_Celula
    
    Sheets("Capa").Range("A60") = Sheets("Lista").Range("P1")
    Sheets("Capa").Range("E60") = Sheets("Lista").Range("P2")
    
    
' IMPRIMIR A CAPA

Sheets("Capa").Select

    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False



' IMPRIMIR A INSPEÇÃO

If Planilha = "" Then

MsgBox "Inspeção Mantec" ' Caso não tenho o nome da planilha

Else


Sheets(Planilha).Select


  ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
      
 End If
 
        
' IMPRIMIR SEGURANÇA

Sheets(Tipo).Select

    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False





    


Else

MsgBox "CLIQUE NO RE PARA EXECUTAR A MACRO"



End If

    
Sheets("Lista").Select



End Sub

Postado : 26/10/2016 9:44 am

WRSouza

(@wrsouza)

Posts: 8

Active Member

Romanholi, boa tarde.

Teria como colocar um exemplar deste arquivo?

Postado : 26/10/2016 1:35 pm

MPrudencio

(@mprudencio)

Posts: 2749

Famed Member

Cole esse codigo em um modulo associe a um botao.


Sub Imprime()


If Target.Column = 4 Then


Dim Nome_Celula As String

Nome_Celula = ActiveCell.Value
Setor = ActiveCell.Offset(0, -1).Value
Tipo = ActiveCell.Offset(0, -2).Value
Responsavel = ActiveCell.Offset(0, 1).Value
Planilha = ActiveCell.Offset(0, 5).Value



    Form_Data.Show
    
    '   Inseri essas duas linhas
    
    Cells(5, 4).Select
     
    Do While ActiveCell.Value <> ""

    Sheets("Capa").Select

    Sheets("Capa").Range("A33") = Setor
    Sheets("Capa").Range("A35") = Tipo
    Sheets("Capa").Range("C54") = Nome_Celula
    
    Sheets("Capa").Range("A60") = Sheets("Lista").Range("P1")
    Sheets("Capa").Range("E60") = Sheets("Lista").Range("P2")
    
    
' IMPRIMIR A CAPA

Sheets("Capa").Select

    ActiveWindow.SelectedSheets.PrintOut


' IMPRIMIR A INSPEÇÃO

If Planilha = "" Then

MsgBox "Inspeção Mantec" ' Caso não tenho o nome da planilha

Else


Sheets(Planilha).Select


  ActiveWindow.SelectedSheets.PrintOut
      
End If

        
' IMPRIMIR SEGURANÇA

Sheets(Tipo).Select

    ActiveWindow.SelectedSheets.PrintOut

Else

MsgBox "CLIQUE NO RE PARA EXECUTAR A MACRO"



End If

'Inseri essa linha
Loop

    
Sheets("Lista").Select



End Sub

As linhas inseridas na planilha estao comentadas.

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

Postado : 26/10/2016 5:28 pm

MPrudencio

(@mprudencio)

Posts: 2749

Famed Member

antes de loop acrescente essa linha


activecell.offset(1,0).select

Para que o cursor pule uma linha do contrario entrara em loop infinito ja que o cursor vai estar travado na celula.

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

Postado : 26/10/2016 6:18 pm

romanholi

(@romanholi)

Posts: 177

Estimable Member

Topic starter

Prudencio, obrigado pelo retorno!
Mas não deu certo!

DeI uma editada no arquivo, veja se pode me ajudar! Removi algumas planilhas para poder fazer o upload!

Segue

Obrigado pela ajuda

Postado : 27/10/2016 10:45 am

Basole

(@basole)

Posts: 487

Reputable Member

romanholi,

Elimine: A linha 'If Target.Column = 4 Then' e o 'End IF' no final , na 'Sub Imprime_Todos'
A macro faz um loop selecionando linha a linha ( 'chamando' Sub Imprime_Todos), na coluna d a partir da linha 5 até a ultima linha com dados.

Sub Loop_()
    Dim Lr As Long, rng As Range, c As Range, ct As Integer

    With ThisWorkbook
        .Activate
        With .Sheets("Lista")

            Lr = .Cells(Rows.Count, 4).End(xlUp).Row

            Set rng = .Range("D5:D" & Lr)
            For Each c In rng
                If c.Value <> "" Then
                    c.Activate
                    '  Imprime_Todos
                    ct = ct + 1
                End If
            Next

        End With
    End With

    If ct > 0 Then MsgBox ct & " impressões com sucesso! ", 0, "Aviso"

End Sub

Click em se a resposta foi util!