Este fórum está sendo desativado

[Filipemzn]

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

[AndersonLeal]

Olá,

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

Abraço!

[Filipemzn]

Boa noite!

Tentei mandar um arquivo de exemplo!

Abs
Obrigado

[Parkeless]

Bom dia,

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

[Filipemzn]

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

[Parkeless]

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

[Filipemzn]

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

[Parkeless]

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.

[Filipemzn]

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