Boa tarde

Para facilitar, anexe um ficheiro de exemplo (arquivo compactado) com poucos dados, demonstrando o que desejas.

[]s

Obrigado Patropi.

envio uma pequena parte do ficheiro para teste,

https://drive.google.com/file/d/0B9YYmIQcUzxdZkZvUzBKYWVXYWc/view?usp=sharing

a ideia era arranjar uma macro ou outra forma, de fazer o filtro na coluna Fornecedor (H) e depois com os dados obtidos copiar/exportar para um novo ficheiro de forma automatica...

exemplo filtro por 2024438 (são 93 dados) e com a informação resultante copiar ou exportar automaticamente para um novo ficheiro com o nome de 2024438, filtro por 2024918 são 2 linhas copiar o resultado para

novo ficheiro e salvar com o nome 2024918, e assim sucessivamente por cada um dos dados da coluna H, obtendo no final tantos novos ficheiros quantos os existem na coluna H (já agrupado por fornecedor).

Alguma duvida é só dizer, obrigado mais uma vez.

Bom dia!!

Veja se ajuda, caso necessário, tente adaptar!

Sub AleVBA_14081()
    Dim a, i As Long, dic As Object, ws As Worksheet, e
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("Final").Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not dic.exists(a(i, 6)) Then Set dic(a(i, 6)) = .Rows(1)
            Set dic(a(i, 6)) = Union(dic(a(i, 6)), .Rows(i))
        Next
    End With
    Set ws = Sheets.Add
    For Each e In dic
        ws.Name = e
        ws.Cells.Clear
        dic(e).Copy ws.Cells(1)
        ws.Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & e & ".xlsx"
        ActiveWorkbook.Close False
    Next
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Att

Obrigado Alexandrevba

Dá erro na linha ws.Name = e ...

a coluna a filtrar no ficheiro original é a j ... alterei para ws.Name = j mas continua a dar erro...
tenho mais folhas também no ficheiro original mas o nome da que tem os dados a filtrar é o mesmo "Final"

se der para verificar o problema agradeço.

obrigado abc

Boa tarde!!

Infelizmente eu não ative problemas, você testou no mesmo arquivo que postou?

Caso não (ou se fez alguma alteração), há como postar o arquivo em que está usando o código?

Att

Realmente no ficheiro que mandei funciona

Posso mandar e-mail pra você com o ficheiro original?

obrigado

Boa tarde!!

Ok, pode sim!

Eu espero poder ajudar....

Att

ok

já enviei depois coloco o ficheiro alterado para ficar como teste para todos

Obrigado pela disponibilidade

Boa tarde!!

Foi feito a adaptação, de acordo com seu arquivo.

Sub AleVBA_14081V2()
    Dim a, i As Long, dic As Object, ws As Worksheet, e
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("Final").Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not dic.exists(a(i, 10)) Then Set dic(a(i, 10)) = .Rows(1)
            Set dic(a(i, 10)) = Union(dic(a(i, 10)), .Rows(i))
        Next
    End With
    Set ws = Sheets.Add
    For Each e In dic
        ws.Name = e
        ws.Cells.Clear
        dic(e).Copy ws.Cells(1)
        ws.Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & e & ".xlsx"
        ActiveWorkbook.Close False
    Next
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Faça os testes.
Att

Obrigado

já funciona.

Eu tinha alterado as linhas como você alterou,
For i = 2 To UBound(a, 1)
If Not dic.exists(a(i, 10)) Then Set dic(a(i, 10)) = .Rows(1)
Set dic(a(i, 10)) = Union(dic(a(i, 10)), .Rows(i))

o problema era que continuava a dar erro... mesmo esse comando acima dá Erro run time erro 1004,

mas o problema era o nome do fornecedor que excedia os 31 caracteres, depois de alterados alguns ficou a funcionar na perfeição.

Valeu, obrigado pela disponibilidade, poupou algumas horas de trabalho

abraço