Guru do Excel e Power BI

Boa noite amigos!

Estou tentando automatizar uma planilha da seguinte maneira: Dados sobre fornecedores são colocados em uma linha de uma aba "Geral", está linha quando rodada a macro copiaria esta linha para a aba do fornecedor correspondente. Até ai o meu código parece que fez, o problema é que sempre que rodo a macro ele copia novamente esses dados, será que existe alguma maneira de fazer com que ele copie essa linha para sua aba sem copiar o que ja foi feito?

Segue meu código abaixo:
Sub Copia()

Application.CutCopyMode = False

Dim r As Long, c As Long
Dim ws As Worksheet
Dim sFornecedores As String
Dim wsRow As Long

Worksheets("Geral").Activate
r = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'find last row
c = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column 'find last column
Range("A6").AutoFilter
Range("A1:A" & r).AutoFilter Field:=1

For Each ws In Worksheets
If ws.Name <> "Geral" Then
'*edited to accommodate pre-existing data
ws.Activate '*activate sheet so you can use Cells() with it
wsRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1 '*find first usable row in ws
sFornecedores = ws.Name 'criteria to look for
Worksheets("Geral").Activate 'bring focus back to main sheet
Range("B3:B" & r).AutoFilter Field:=2, Criteria1:=sFornecedores
Range(Cells(1, 1), Cells(r, c)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A" & wsRow)
End If
Next ws

Range("A1").AutoFilter

Application.CutCopyMode = True
End Sub

Este é meu primeiro post, então me desculpem caso tenha feito algo errado rs.

Abraços e uma ótima noite a todos..
Filipe

Olá,

Poste uma planilha de exemplo que fica mais fácil de ajudar!

Abraço!

Boa noite!

Tentei mandar um arquivo de exemplo!

Abs
Obrigado

Bom dia,

Já tentou usar um "Remover Duplicatas" no final da Macro?

Boa tarde amigo, obrigado, não tinha pensado nisso.. rs

Alterei o código e tentei remover as duplicatas com o código abaixo, porém ele esta levando o cabeçalho na copia, e nao está removendo as duplicatas...

Sub Copia()

Application.CutCopyMode = False

Dim r As Long, c As Long
Dim ws As Worksheet
Dim sFornecedores As String
Dim wsRow As Long

Worksheets("Geral").Activate
r = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'find last row
c = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column 'find last column
Range("A1").AutoFilter
Range("A2:A" & r).AutoFilter Field:=1

For Each ws In Worksheets
If ws.Name <> "Geral" Then
'*edited to accommodate pre-existing data
ws.Activate '*activate sheet so you can use Cells() with it
wsRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1 '*find first usable row in ws
sFornecedores = ws.Name 'criteria to look for
Worksheets("Geral").Activate 'bring focus back to main sheet
Range("A3:A" & r).AutoFilter Field:=2, Criteria1:=sFornecedores
Range(Cells(1, 1), Cells(r, c)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A" & wsRow)
With ActiveSheet
Set Rng = Range("A1", Range("B1").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
End With

End If
Next ws

Range("A1").AutoFilter

Application.CutCopyMode = True
End Sub

Obrigado pela ajuda!
abs
Filipe

Seria isso?

Código: Selecionar todos

Sub Dividir_Dados()

Dim cell As Range
Dim Aba As Worksheet
Dim Linha As Long

For Each cell In Range("A:A").SpecialCells(xlCellTypeConstants)
    Set Aba = Sheets(cell.Offset(0, 1).Value)
    If Aba.Range("A1") = "" Then
        Linha = 1
    Else
        Linha = Aba.Range("A1000000").End(xlUp).Offset(1, 0).Row
    End If
    Aba.Cells(Linha, 1) = cell.Offset(0, 0)
    Aba.Cells(Linha, 2) = cell.Offset(0, 1)
    Aba.Cells(Linha, 3) = cell.Offset(0, 2)
    Aba.Cells(Linha, 4) = cell.Offset(0, 3)
    Aba.Cells(Linha, 5) = cell.Offset(0, 4)
Next cell

'Remover Duplicatas
For Each Aba In Worksheets
    If Aba.Name <> "Geral" Then
        Aba.Range("A:E").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5) _
        , Header:=xlNo
    End If
Next Aba

End Sub

Bom dia amigos,

Primeiramente gostaria de agradecer a ajuda de vcs, todos os posts estão sendo muito úteis e estou aprendendo bastante sobre as macros!

Fiz o seguinte, resolvi abrir duas macros, uma pra copiar as linhas pros fornecedores:

Código: Selecionar todos

Sub Copia()

Application.CutCopyMode = False

Dim r As Long, c As Long
Dim ws As Worksheet
Dim sFornecedores As String
Dim wsRow As Long
Dim rng As Range

Worksheets("Geral").Activate
r = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'find last row
c = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column 'find last column
Range("A1").AutoFilter
Range("A2:A" & r).AutoFilter Field:=2

For Each ws In Worksheets
    If ws.Name <> "Geral" Then
        '*edited to accommodate pre-existing data
        ws.Activate '*activate sheet so you can use Cells() with it
        wsRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1 '*find first usable row in ws
        sFornecedores = ws.Name 'criteria to look for
        Worksheets("Geral").Activate 'bring focus back to main sheet
        Range("A2:A" & r).AutoFilter Field:=2, Criteria1:=sFornecedores
        Range(Cells(1, 1), Cells(r, c)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A" & wsRow)
        
    End If
    
 
    
Next

    

Range("A1").AutoFilter

Application.CutCopyMode = True
End Sub

E outra para remover a duplicata como nosso amigo disse no post acima:

Código: Selecionar todos

Sub Dividir_Dados()

Dim ws As Worksheet


For Each ws In Worksheets
    Cells.Select
    ActiveSheet.Range("$A$1:$J$127").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes

   Next
    
Worksheets("Geral").Activate

   
End Sub

Está quase tudo OK, o que falta resolver agora é tirar a cópia do cabeçalho da tabela principal (está copiando junto sempre a primeira linha e as demais correspondentes) e entender pq o código de remover duplicatas não funciona pra várias abas, testei em duas, e só removeu em uma...

Obrigado novamente

Abs
Filipe

Olá Felipe,

Tenta depurar o seu código; acho que você mesmo consegue identificar o problema.

Abra o VBE, coloque ele ao lado de sua planilha, e vá apertando F8 para visualizar passo a passo o que a macro está fazendo.

Qualquer dúvida estamos aqui.

Bom dia!

Obrigado pela ajuda! Encontrei o erro!

O código para copiar as linhas nas outras abas estava OK, o comando remover duplicatas não estava funcionado por estar usando o .select para remover as duplicatas, por algum motivo isso fazia apenas funcionar na planilha selecionada.

Troquei o .select por ws.range e o intervalo que eu precisava remover as duplicatas e coloquei essa linha no fim do código da cópias das linha, o código ficou assim:

Código: Selecionar todos

Sub Copia()

Application.CutCopyMode = False

Dim r As Long, c As Long
Dim ws As Worksheet
Dim sFornecedores As String
Dim wsRow As Long
Dim rng As Range

Worksheets("Geral").Activate
r = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'find last row
c = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column 'find last column
Range("A1").AutoFilter
Range("A2:A" & r).AutoFilter Field:=2

For Each ws In Worksheets
    If ws.Name <> "Geral" Then
        '*edited to accommodate pre-existing data
        ws.Activate '*activate sheet so you can use Cells() with it
        wsRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1 '*find first usable row in ws
        sFornecedores = ws.Name 'criteria to look for
        Worksheets("Geral").Activate 'bring focus back to main sheet
        Range("A2:A" & r).AutoFilter Field:=2, Criteria1:=sFornecedores
        Range(Cells(1, 1), Cells(r, c)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A" & wsRow)
        ws.Range("A:J").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
        7, 8, 9, 10), Header:=xlYes
    End If
    
 
    
Next

    

Range("A1").AutoFilter

Application.CutCopyMode = True
End Sub

Desta maneira é feita a cópia em todas as abas, e logo apos removidas as linhas repetidas.

Muito obrigado pessoal, agradeço muito pelo comentários. Um grande abraço a todos.

Filipe

Guru do Excel e Power BI

Macro para automatização de planilha

Macro para automatização de planilha

Macro para automatização de planilha

Re: Macro para automatização de planilha

Macro para automatização de planilha

Re: Macro para automatização de planilha

Macro para automatização de planilha

Re: Macro para automatização de planilha

Re: Macro para automatização de planilha

Re: Macro para automatização de planilha