Tente assim :

    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

Dim rng As Range
Dim Ult_Col As String
Dim Prim_Col 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
With ActiveSheet.UsedRange
    lprimcol = .Column
    lultcol = .Columns(UBound(.Value, 2)).Column
End With

Ult_Col = Cells(, lultcol).Address(0, 0)
Prim_Col = Cells(, lprimcol).Address(0, 0)
 
Set rng = Range(Prim_Col & ":" & Ult_Col)
'vTitles = "A1:Z1"
vTitles = rng.Address(0, 0)
    
    '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

Dá erro em

lprimcol = .Column
lultcol = .Columns(UBound(.Value, 2)).Column
"Variable not defined"

Me esqueci do Básico quando iniciamos em VBA, este erro ocorre devido em seu módulo estar utilizando :

Option Explicit que obriga a Declarar todas as Variáveis.

então é só acrescentar :
Dim lprimcol
Dim lultcol

[]s

Mauro,

É possivel fazer isso também neste código?

    Set owbk = Workbooks.Open(WSR.Range("DIRETORIO_1") & "Arquivo_1.xlsx")
    Range("A2", Range("FK" & Rows.Count).End(xlUp)).Copy
    sh.Range("A" & UltimaLinha).PasteSpecial xlPasteValues
    owbk.Close False

Mauro,
É possivel fazer isso também neste código?

    Set owbk = Workbooks.Open(WSR.Range("DIRETORIO_1") & "Arquivo_1.xlsx")
    Range("A2", Range("FK" & Rows.Count).End(xlUp)).Copy
    sh.Range("A" & UltimaLinha).PasteSpecial xlPasteValues
    owbk.Close False

Poderia detalhar melhor o que pretende ? Fazer o que ?

[]s

Neste caso estou a copiar dados de uma sheet para outra. Mas a coluna "FK" pode não ser fixa... Os dados começam sempre na coluna A2, mas podem não acabar em "FK".

Se A2 é sempre fixo, pode usar a instrução abaixo :

Range("A2").CurrentRegion.Offset(1, 0).Resize( _
        Range("A2").CurrentRegion.Rows.Count - 1, _
            Range("A2").CurrentRegion.Columns.Count).Copy

[]s

Valeu Mauro.

Pode só me explicar porque mete "-1" no código? Assim me esmaga informação se usar o mesmo código para colar novamente

Neste código também não consigo utilizar a lógica anterior.

Aqui pretendo pintar a ultima linha de amarelo, mas a coluna pode ser diferente de "CJ"

Set sh = ActiveSheet
UltimaLinha = sh.Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & UltimaLinha, Range("CJ" & UltimaLinha)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Valeu Mauro.

Pode só me explicar porque mete "-1" no código? Assim me esmaga informação se usar o mesmo código para colar novamente

Miguexcel, eu não sei o que quer dizer com a expressão :
"Assim me esmaga informação se usar o mesmo código para colar novamente"

Mas quanto a sua pergunta, o ideal quando estamos começando a lidar com VBA é procurar ler um pouco sobre o assunto e conhecermos pelo menos os principios básicos e uma outra dica que eu acho bem valiosa é utilizar o recurso Passo a Passo (F8) na janela do VBA para seguirmos a execução da macro.

Então para você poder compreender melhor faça o seguinte :
1º ) Abra uma nova planilha qualquer e preencha com dados qualquer da celula A1 até D15;
2º ) Abra a janela do VBA ALT + F11 e cole as rotinas abaixo :

Altere o tamanho da Janela do VBA de modo que posso enxergar a aba com os dados ao fundo, e vá pressionando a tecla F8, verá que aparecerá uma linha amarela a cada toque do F8, ou seja estamos executando a rotina passo a passo.

Assim, ao executar esta rotina verá que será selecionado todas as celulas preenchidas.

Sub SelecionaTudo()
    ActiveCell.CurrentRegion.Select
End Sub

Como na rotina estamos usando ActiveCell, significa a celula ativa, então supondo que a celula selecionada seja qualquer uma dentro da tabela que tenha dados será selecionado de A1 até D15, mas supondo que a celula selecionada seja E1 então será selecionada de A1 até E15 ,e se a celula selecionada for E16 será selecionado de A1 até E16, ou seja, foi selecionado uma linha e coluna vazia, e devido a isto utilizamos o -1, tudo isto poderá acompanhar utilizando o F8.

CurrentRegion - representa a região com dados, ou seja se a celula selecionada for em uma área sem dados, não será selecionado nada.

agora na rotina que passei :

Range("A2").CurrentRegion.Offset(1, 0).Resize( _
        Range("A2").CurrentRegion.Rows.Count - 1, _
            Range("A2").CurrentRegion.Columns.Count).Copy

No lugar de A2 poderia ser ActiveCell, mas isto me forçaria a instruir antes que fosse selecionado um Range, e como passou A2 só incrementei da forma que estava, poderia ter colocado A1 tambem.
Como leu acima, ActiveCell.CurrentRegion.Select, selecionará sempre uma linha vazia abaixo da que contem dados, então instruímos -1 que é para retornar o foco para uma linha acima da preenchida.

Traduzindo a rotina, temos :
CurrentRegion - região com dados
Offset(1, 0) - Estamos considerando que temos uma linha de cabeçalho, assim ignoramos esta linha,
Resize(Range("A1").CurrentRegion.Rows.Count - estamos redimensionando o Range utilizando a contagem de linhas, e neste caso se não utilizarmos o -1, se executar no modelo que eu disse acima, será selecionado até a linha 16 que está em branco.

Execute utilizando a tecla F8, elimine o -1 e depois coloque novamente e poderá entender melhor.
Me estendi demais, espero que tenha compreendido.

Mas procure montar este modelo que passei e executar passo a passo estas instruções, irá entender bem melhor.

[]s

Neste código também não consigo utilizar a lógica anterior.

Aqui pretendo pintar a ultima linha de amarelo, mas a coluna pode ser diferente de "CJ"

Set sh = ActiveSheet
UltimaLinha = sh.Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & UltimaLinha, Range("CJ" & UltimaLinha)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Esta eu já respondi em meu primeiro post, é só seguir o mesmo principio para coletar a última coluna e depois incrementar em sua linha, tipo :
Range("A" & UltimaLinha, Range(Ultima_Coluna & UltimaLinha)).Select

[]s

Valeu Mauro. Grande ajuda.

Tenho só mais uma dúvida. O código serve para separar um ficheiro em outros arquivos com base numa determinada coluna que tem diferentes dados (por exemplo: idade). No entanto, se por acaso me aparecer um arquivo que só tenha uma idade, o código dá erro aqui "For Itm = 1 To UBound(MyArr)". Não percebo porquê...

Muito Obrigado por sua ajuda.

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