Sub Разделить_столбец_по_книгам()
Const column = 7 'номер столбца, по которому будет происходить разделение.'
Const head = True
Set wbAct = ActiveWorkbook

Set dic = CreateObject("Scripting.Dictionary")

lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).column

arr = Range("A1", Cells(lr, lc)).Value

If head Then fr = 2 Else fr = 1

For i = fr To UBound(arr)
    If Trim(arr(i, column)) <> "" Then dic.Item(arr(i, column)) = dic.Item(arr(i, column)) & "|" & i
Next

iPath = wbAct.Path & Application.PathSeparator & "Result" & Application.PathSeparator
'Result - название папки с результатами'
If Dir(iPath, vbDirectory) = "" Then MkDir iPath

arrDic = dic.keys
Set Rng = Nothing
Application.DisplayAlerts = False
For i = 0 To UBound(arrDic)
rrs = Split(Mid(dic.Item(arrDic(i)), 2), "|")
    If head Then Set Rng = Rows(1)
    For Each rr In rrs
        If Not Rng Is Nothing Then Set Rng = Union(Rows(rr), Rng) Else Set Rng = Rows(rr)
    Next
    Set wb = Workbooks.Add(1)
    Set sh = wb.Sheets(1)
    Rng.Copy
    sh.[A1].PasteSpecial xlPasteColumnWidths
    sh.[A1].PasteSpecial xlPasteAll
    Set Rng = Nothing
    wb.SaveAs iPath & Replace_symbols(arrDic(i)) & ".xlsx", xlOpenXMLWorkbook
    wb.Close False
Next
Application.DisplayAlerts = True
End Sub
'Замена запрещённых символов в имени файла или папки'
Function Replace_symbols(ByVal txt As String) As String
    St$ = "\\/~!@#$%^&*=|`'"""
    For i% = 1 To Len(St$)
        txt = Replace(txt, Mid(St$, i, 1), "_")
    Next
    Replace_symbols = txt
End Function