Bom dia!!

Visto que seu arquivo modelo e compactado, não está disponível ....

Tente adaptar...

Option Explicit

Sub ParseItems()
'Jerry Beaucaire  (4/22/2010)
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

'Sheet with data in it
   Set ws = Sheets("Original Data")

'Path to save files into, remember the final 
    SvPath = "C:2010"

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:Z1"
   
'Choose column to evaluate from, column A = 1, B = 2, etc.
   vCol = Application.InputBox("What column to split data by? " & vbLf _
        & vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
   If vCol = 0 Then Exit Sub

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Speed up macro execution
   Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
        
        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
        
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY"), xlNormal
        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51   'use for Excel 2007+
        ActiveWorkbook.Close False
        
        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
    Application.ScreenUpdating = True
End Sub

Att

Alex,

Envio arquivo novamente. Não estou conseguindo adaptar

Bom dia!!

Altere essas linhas conforme sua necessidade

   Set ws = Sheets("AleVBA_Guia") 'O nome da guia que contém os dados

    SvPath = "C:UsersalexandreVBADownloads" 'Local onde vai salvar

Att

Alex,

Está perfeito. Só tem uma dúvida. Existe forma de fazer isto para arquivos externos? OU seja, deixo a macro num arquivo isolado, em que abre os diferentes arquivos com informação e faz esse trabalho...?

Boa tarde!!

Por favor, click na mãozinha!!

Sua pergunta não condiz com sua postagem original, mas respondendo sua pergunta, se eu entendi bem, sim é possível.

Existe forma de fazer isto para arquivos externos? OU seja, deixo a macro num arquivo isolado, em que abre os diferentes arquivos com informação e faz esse trabalho...?

Att