Насколько я понимаю ваш вопрос, у вас есть лист, который в первом столбце содержит значения, которым назначены ваши строки данных. Вы хотите изолировать строки, назначенные каждому из этих значений, и сохранить строки для каждого значения на отдельном рабочем листе. Я предполагаю, что вы хотите избежать этого вручную, учитывая количество кодов, которые вы упомянули.
Следующий код VBA может удовлетворить ваши потребности. Он включает процедуру, которая применяет значения фильтра к таблице Excel и сохраняет результаты в отдельных книгах, а также функцию утилиты, которая идентифицирует уникальные значения, которые необходимо отфильтровать.
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
