As I understand your question, you have a worksheet that in the first column contains values to which your data rows are assigned. You want to isolate the rows that are assigned to each of those values and save the rows for each value to a separate worksheet. I am assuming you want to avoid doing this by hand, given the number of recodes that you mention.
The following VBA code may suit your needs. It includes a procedure that applies filter values to an Excel table and saves the results to individual workbooks, as well as a utility function that identifies the unique values that need to be filtered.
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
