Sub Разделить_столбец_по_книгам_MAC()
Const column = 7 'номер столбца, по которому будет происходить разделение.'
Const head = True
Dim iCol As New Collection
Dim I&, iKey, iTmp

Set wbAct = ActiveWorkbook
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 Application.Trim(arr(I, column)) <> "" Then
    iKey = Application.Trim(arr(I, column))
    If KeyExists(iKey, iCol) Then
      iTmp(1) = iCol.Item(iKey)(1) & "|" & I: iTmp(2) = iKey
      iCol.Remove (iKey)
    Else
      ReDim iTmp(1 To 2)
      iTmp(1) = I: iTmp(2) = iKey
    End If
    iCol.Add iTmp, iKey
  End If
Next
 
'Result - название папки с результатами'
iPath = wbAct.Path & Application.PathSeparator & "Result" & Application.PathSeparator
If Dir(iPath, vbDirectory) = "" Then MkDir iPath
 
Set Rng = Nothing
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For I = 1 To iCol.Count
rrs = Split(iCol.Item(I)(1), "|")
    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
    With sh.[A1]
      .PasteSpecial xlPasteColumnWidths
      .PasteSpecial xlPasteAll
      .Select
    End With
    Set Rng = Nothing
    wb.SaveAs iPath & Replace_symbols(iCol(I)(2)) & ".xlsx", xlOpenXMLWorkbook
    wb.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

'Замена запрещённых символов в имени файла или папки'
Private 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

'Проверка наличия ключа в коллекции
Private Function KeyExists(ByVal key$, ByRef container As Collection) As Boolean
  On Error Resume Next
  Dim temp As Variant
  temp = container.Item(key)
  KeyExists = IIf(IsEmpty(temp), False, True)
  On Error GoTo 0
End Function