Pelo que entendi, você tem uma planilha que, na primeira coluna, contém valores aos quais as linhas de dados são atribuídas. Você deseja isolar as linhas atribuídas a cada um desses valores e salvar as linhas de cada valor em uma planilha separada. Eu estou supondo que você queira evitar fazer isso manualmente, dado o número de recodificações que você mencionou.
O código VBA a seguir pode atender às suas necessidades. Ele inclui um procedimento que aplica valores de filtro a uma tabela do Excel e salva os resultados em pastas de trabalho individuais, bem como uma função de utilitário que identifica os valores exclusivos que precisam ser filtrados.
Option Explicit
Sub FilterTableAndSave()
'Filters a data range on the values in the first
' column of the range and saves the filtered
' values to separate worksheets. The data range
' is assumed to start in cell A1 and have
' column header names in row 1 of the range.
'
' The workbooks are saved under names that begin with
' a specified prefix and end with the filter value,
' e.g., "FILEAcme Corporation". The directory to which
' the files are saved and the file prefix must be specified
' below.
Dim wb As Workbook
Dim ws As Worksheet, newWs As Worksheet
Dim tableRng As Range, filterValuesRng As Range, lastcell As Range
Dim saveDir As String, savePathAndName As String
Dim msgResponse As String, saveNamePrefix As String
Dim inputArr() As Variant, resultArr() As Variant
Dim resultIndex As Long
On Error GoTo ExitErr
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'*********************************************
' SET THE SAVE DIRECTORY AND FILE PREFIX HERE
'*********************************************
saveDir = "e:\"
saveNamePrefix = "FILE"
'*********************************************
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set lastcell = Cells.Find(What:="*", After:=[A1], _
SearchDirection:=xlPrevious)
Set tableRng = Range("$A$1:" & lastcell.Address)
Set filterValuesRng = Range("$A$2:$A$" & lastcell.Row)
With ws
On Error Resume Next 'Convert data range to table
.ListObjects.Add(SourceType:=xlSrcRange, Source:=tableRng, _
XlListObjectHasHeaders:=xlYes).Name = "Main"
On Error GoTo ExitErr
End With
inputArr = filterValuesRng 'Assign filter column to array
resultArr = GetDistinctElements(inputArr)
For resultIndex = LBound(resultArr) To UBound(resultArr) 'Loop through filter values
With ws
On Error Resume Next
.ShowAllData
On Error GoTo ExitErr
.ListObjects("Main").Range.AutoFilter _
Field:=1, Criteria1:="=" & resultArr(resultIndex) 'Set current filter value
.ListObjects("Main").Range.Copy 'Copy filtered rows
End With
Set newWs = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 'Create new workbook and
On Error Resume Next 'paste filtered rows into it
With newWs.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValuesAndNumberFormats
.Select
Application.CutCopyMode = False
End With
On Error GoTo ExitErr
Set wb = ActiveWorkbook 'File save routine
savePathAndName = saveDir & saveNamePrefix & _
resultArr(resultIndex) & ".xlsx"
If Dir(savePathAndName) = "" Then
wb.SaveAs savePathAndName
wb.Close
Else 'Deal with existing files, if any
msgResponse = MsgBox("File " & saveNamePrefix & _
resultArr(resultIndex) & _
".xlsx already exists." & vbCrLf & _
"Replace the existing file?", _
vbYesNoCancel)
If msgResponse = vbYes Then
Application.DisplayAlerts = False
wb.SaveAs savePathAndName
wb.Close
Application.DisplayAlerts = True
Else
Application.DisplayAlerts = False
wb.Close
Application.DisplayAlerts = False
End If
End If
Next resultIndex
ws.ShowAllData 'Convert data table back to range
ws.ListObjects("Main").Unlist 'and remove formatting
With tableRng
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Font.Bold = False
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
ws.Range("A1").Select
Exit Sub
ExitErr:
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set ws = Nothing
Set newWs = Nothing
MsgBox "Error " & Err.Number & ": " & Err.Description, vbOKOnly, "Error"
End Sub
Function GetDistinctElements(ByRef inputArr)
'returns a 1-D array of unique items from an N-by-2
' input array of data items with duplicates.
' The input array would normally be generated by
' assigning a single-column worksheet range to
' a Variant array.
Dim dict As Object
Dim i As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(inputArr) To UBound(inputArr)
dict(inputArr(i, 1)) = 1
Next i
GetDistinctElements = dict.Keys()
End Function