Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Ligando uma rotina ...
 
Notifications
Clear all

Ligando uma rotina a outra.

 
2024 - VBA & Macros
Post Recente por Fabiosp 11 anos atrás
14 Posts
2 Usuários
0 Reactions
2,026 Visualizações
RSS
 Fabiosp
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Prezados colegas bom dia.

Tenho 2 rotinas que foram criadas pelo mestre Wagner Morel e a outra pelo mestre Bernardo.
Estava tentando adaptar para minha planilha pois conforme fui mexendo foram surgindo outros dados a serem coletados.
Enfim, tentei juntar a rotina do Mestre Wagner Morel e a do mestre Bernardo e não consegui, talvez seja pela minha falta de conhecimento em VBA apesar de gostar e ter muito interesse no assunto.
Abaixo segue a rotina e o link dos tópicos criados.

   Option explict

Sub colar()
Dim i       As Long
Dim UltLDad As Long
Dim UltLDup As Long
Dim wb      As Workbook
Dim Dad     As Worksheet
Dim Rel     As Worksheet
Dim Dup     As Worksheet

Set wb = ThisWorkbook
Set Dad = wb.Sheets("dados")
Set Rel = wb.Sheets("relatorio")
Set Dup = wb.Sheets("duplicado")

UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual

    Dad.Range
Workbooks("RELATORIO.xls").Activate
        For i = 1 To Sheets.Count
            Sheets(i).Select
            UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
            If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
            For j = 2 To UltimaLinhaRelat
                If Trim(Range("K" & j).Value) = "verificado" Then
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("A" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("A" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("B" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("B" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("C" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("C" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("D" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("D" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("E" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("E" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("F" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("F" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("G" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("G" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("H" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("H" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("I" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("I" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("J" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("J" & j).Value
                    Workbooks("RELATORIO GERAL.xls").Sheets("RELATORIO GERAL").Range("K" & UltimaLinhaGeral).Value = Workbooks("RELATORIO.xls").ActiveSheet.Range("K" & j).Value
                    UltimaLinhaGeral = UltimaLinhaGeral + 1
                End If
            Next
        Next
        Sheets("JAN-13").Select
    
    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Rel.Range("A1:A" & i), Rel.Range("A" & i).Text) > 1 Then
            Rel.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Rel.Range("A" & i).EntireRow.Delete
        End If
    Next i

Set wb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Rotina criada pelo mestre Wagner Morel
http://www.planilhando.com.br/forum/viewtopic.php?f=10&t=9768

Rotina criada pelo mestre Bernardo

http://www.planilhando.com.br/forum/viewtopic.php?f=10&t=9857

Desde já agradeço a todos colegas deste fórum.

Abraços.

 
Postado : 09/12/2013 6:47 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia Fabiosp,

Bom, sem a planilha fica um pouco difícil testar, ainda mais com dois códigos distintos. Mas testa esse código.

Option Explicit
Sub colar()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet
Dim GRel                As Worksheet


Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("dados")
Set Rel = Twb.Sheets("relatorio")
Set Dup = Twb.Sheets("duplicado")
Set GRel = Sheets("RELATORIO GERAL")


UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual


Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = 2 To UltimaLinhaRelat
            If Trim(Range("K" & j).Value) = "verificado" Then
                GRel.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).Copy
                Gwb.ActiveSheet.Range("A" & j & ":K" & j).PasteSpecial Paste:=xlPasteValues
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next
    Sheets("JAN-13").Select
    
    Dad.Range("M17:Q42").Copy
    Rel.Range("A2").PasteSpecial Paste:=xlPasteValues
    MsgBox "Apos Gerar O Relatorio Utilzar Apenas Bordas Externas No Campo Das Informacoes E Depois De Concluido Imprimir O Documento."
    
    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Rel.Range("A1:A" & i), Rel.Range("A" & i).Text) > 1 Then
            Rel.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Rel.Range("A" & i).EntireRow.Delete
        End If
    Next i

Set Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Me fala a linha que etá aparecendo o erro.
Ou me manda a planilha com a adaptação para ir testando.

Qualquer coisa da o grito.
Abraço

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

 
Postado : 09/12/2013 7:10 am
 Fabiosp
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Mestre Bernardo Bom dia

Muito obrigado pela ajuda!

segue a planilha

Bom, sem a planilha fica um pouco difícil testar, ainda mais com dois códigos distintos. Mas testa esse código.

Option Explicit
Sub colar()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet
Dim GRel                As Worksheet


Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("dados")
Set Rel = Twb.Sheets("relatorio")
Set Dup = Twb.Sheets("duplicado")
Set GRel = Sheets("RELATORIO GERAL")


UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual


Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = 2 To UltimaLinhaRelat
            If Trim(Range("K" & j).Value) = "verificado" Then
                GRel.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).Copy
                Gwb.ActiveSheet.Range("A" & j & ":K" & j).PasteSpecial Paste:=xlPasteValues
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next
    Sheets("JAN-13").Select
    
    Dad.Range("M17:Q42").Copy
    Rel.Range("A2").PasteSpecial Paste:=xlPasteValues
    MsgBox "Apos Gerar O Relatorio Utilzar Apenas Bordas Externas No Campo Das Informacoes E Depois De Concluido Imprimir O Documento."
    
    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Rel.Range("A1:A" & i), Rel.Range("A" & i).Text) > 1 Then
            Rel.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Rel.Range("A" & i).EntireRow.Delete
        End If
    Next i

Set Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Me fala a linha que etá aparecendo o erro.
Ou me manda a planilha com a adaptação para ir testando.

Qualquer coisa da o grito.
Abraço

RELATORIO2013.zip
 
Postado : 09/12/2013 7:13 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Cara, as planilhas usadas no código que eu fiz são as mesmas usadas no código que o Wagner fez?

Está faltando Sheets entre os workbooks nas planilhas que me enviou. Não irá funcionar assim.

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

 
Postado : 09/12/2013 7:34 am
 Fabiosp
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Olá Bernardo

As planilhas são as mesmas só inclui algumas plan pra testar a rotina do mestre Wagner Morel.
Esta faltando algumas plan?
Acho que como andei mexendo devo ter apagado algo.
Mas que necessito é copiar toda linha que consta a informação "verificado" da planilha relatório para a planilha relatório geral depois eliminar a duplicidade e colar pra outra plan
Voce havia me ajudado a criar essa parte de eliminar a duplicidade e copiar pra outra plan, porém necessito fazer mesma coisa na planilha onde tenho a rotina criada pelo meste Wagner Morel.

Desde já agradeço a ajuda e desculpe o incomodo caro colega.
Abraços.

 
Postado : 09/12/2013 8:09 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Cara, agora me confundiu tudo...

Não sei se entendi ou fiz certo, mas tenta essa:

Option Explicit
Sub Copiardados()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet
Dim GRel                As Worksheet


Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("RELATORIO GERAL")
Set Dup = Twb.Sheets("DUPLICADO")
Set GRel = Sheets("RELATORIO GERAL")

UltimaLinhaGeral = Dad.Cells(Cells.Rows.Count, 11).End(xlUp).Row + 1
UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual


Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = UltimaLinhaRelat To 2 Step -1
            If Trim(Range("K" & j).Value) = "verificado" Then
                ActiveSheet.Range("A" & j & ":K" & j).Copy
                GRel.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).PasteSpecial Paste:=xlPasteValues
                Range("A" & j).EntireRow.Delete
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next
    Sheets("JAN-13").Select
    
    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Dad.Range("A1:A" & i), Dad.Range("A" & i).Text) > 1 Then
            Dad.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Dad.Range("A" & i).EntireRow.Delete
            UltLDup = UltLDup + 1
        End If
    Next i

Set Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Tem que criar a planilha com o nome de "DUPLICADO" na pasta de trabalho "RELATORIO GERAL".

Qualquer coisa da o grito.
Abraço

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

 
Postado : 09/12/2013 12:26 pm
 Fabiosp
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Boa Noite mestre Bernardo

Vou testar depois na minha planilha pois agora estou em casa e aqui não tenho Excel ... :cry:
Por enquanto só tenho a agradecer pela sua generosidade.

Abraços caro colega.

 
Postado : 09/12/2013 5:21 pm
 Fabiosp
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Caro colega Bernardo bom dia.

Testei a rotina na minha planilha mas não funciona.
Tentei fazer alguns ajustes mas com meu pouco conhecimento em VBA não consegui resolver.
Vou anexar a planilha para ser analisada.

Desde já agradeço a ajuda e desculpa o incomodo.

Abraços.

RELATORIO.rar
 
Postado : 10/12/2013 7:08 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia Fabiosp,

Na planilha "RELATORIO" que enviou não tem informações com "Verificado", alterei um valor aqui para verificado e fiz o teste e funcionou normalmente. Usa esse:

Sub Copiardados_by_Bernardo()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet

Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("RELATORIO GERAL")
Set Dup = Twb.Sheets("DUPLICADO")

UltimaLinhaGeral = Dad.Cells(Cells.Rows.Count, 11).End(xlUp).Row + 1
UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual

Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = UltimaLinhaRelat To 2 Step -1
            If UCase(Trim(Range("K" & j).Value)) = "VERIFICADO" Then
                ActiveSheet.Range("A" & j & ":K" & j).Copy
                Dad.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).PasteSpecial Paste:=xlPasteValues
                Range("A" & j).EntireRow.Delete
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next

    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Dad.Range("A1:A" & i), Dad.Range("A" & i).Text) > 1 Then
            Dad.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Dad.Range("A" & i).EntireRow.Delete
            UltLDup = UltLDup + 1
        End If
    Next i

Set Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Dados Copiados com Sucesso!", vbDefaultButton1, "CoPIA DE DADOS"

End Sub

Qualquer coisa da o grito.
Abraço

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

 
Postado : 10/12/2013 7:34 am
 Fabiosp
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Caro colega Bernardo,

Agora esta funcionando valeu!!
Apenas um detalhe.
Percebi que essa rotina apaga a informação da planilha original e cola na outra, não é?
Apenas por curiosidade tem como fazer apenas copiar sem apagar a original?

Abraços

 
Postado : 10/12/2013 8:13 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia Fabiosp,

Então era isso mesmo... hahahahha

Sub Copiardados_by_Bernardo()
Dim i                   As Long
Dim j                   As Long
Dim UltimaLinhaGeral    As Long
Dim UltimaLinhaRelat    As Long
Dim UltLDad             As Long
Dim UltLDup             As Long
Dim Twb                 As Workbook
Dim Gwb                 As Workbook
Dim Dad                 As Worksheet
Dim Rel                 As Worksheet
Dim Dup                 As Worksheet

Set Twb = ThisWorkbook
Set Gwb = Workbooks("RELATORIO.xls")
Set Dad = Twb.Sheets("RELATORIO GERAL")
Set Dup = Twb.Sheets("DUPLICADO")

UltimaLinhaGeral = Dad.Cells(Cells.Rows.Count, 11).End(xlUp).Row + 1
UltLDad = Dad.Range("A" & Rows.Count).End(xlUp).Row
UltLDup = Dup.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlManual

Gwb.Activate
    For i = 1 To Sheets.Count
        Sheets(i).Select
        UltimaLinhaRelat = ActiveSheet.Cells(Cells.Rows.Count, 11).End(xlUp).Row
        If UltimaLinhaRelat < 2 Then UltimaLinhaRelat = 2
        For j = UltimaLinhaRelat To 2 Step -1
            If UCase(Trim(Range("K" & j).Value)) = "VERIFICADO" Then
                ActiveSheet.Range("A" & j & ":K" & j).Copy
                Dad.Range("A" & UltimaLinhaGeral & ":K" & UltimaLinhaGeral).PasteSpecial Paste:=xlPasteValues
                'Range("A" & j).EntireRow.Delete
                UltimaLinhaGeral = UltimaLinhaGeral + 1
            End If
        Next
    Next

    For i = UltLDad To 1 Step -1
        If Application.WorksheetFunction.CountIf(Dad.Range("A1:A" & i), Dad.Range("A" & i).Text) > 1 Then
            Dad.Range("A" & i).EntireRow.Copy
            Dup.Range("A" & UltLDup).PasteSpecial Paste:=xlPasteValues
            Dad.Range("A" & i).EntireRow.Delete
            UltLDup = UltLDup + 1
        End If
    Next i

Set Twb = Nothing
Set Dad = Nothing
Set Rel = Nothing
Set Dup = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Dados Copiados com Sucesso!", vbDefaultButton1, "CoPIA DE DADOS"

End Sub

Qualquer coisa da o grito.
Abraço

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

 
Postado : 10/12/2013 8:18 am
 Fabiosp
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Mestre Bernardo
Era isso mesmo hahaha!!
Agora ficou perfeito !!
Valeu a ajuda mestre.
Desculpe o incomodo.

Abraços.

 
Postado : 10/12/2013 10:22 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Tranquilo 8-)
Qualquer coisa da o grito que a gente dá um jeito.
Abraço

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

 
Postado : 10/12/2013 10:24 am
 Fabiosp
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Valeu pela força mestre!!

Abraços

 
Postado : 10/12/2013 10:30 am
Forum Jump:
  Tópico Anterior
Próximo Tópico