Категория клиента = RANKX(ALL('Продажи'[Дата]);'Продажи'[КонтрагентID];;ASC;Dense)

RANK()OVER(PARTITION BY [contactid] ORDER BY [invoicedate])

Public Sub Split()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Im_Main, PUT_FILE, PUT_FILE_out, sch_lst, Lst_Spisok, Last_Col, fama, index, stolb As Variant
Dim ii, JJ, kk As Integer
Im_Main = ActiveWorkbook.Name
PUT_FILE = Application.ActiveWorkbook.Path + "\"
Lst_Spisok = "Lst"
sch_lst = ActiveWorkbook.Sheets.Count
Dim Name_Lst() As Variant
ReDim Name_Lst(sch_lst)
For ii = 1 To ActiveWorkbook.Sheets.Count
    Name_Lst(ii) = Trim(Sheets(ii).Name)
Next 'ii
Sheets(Lst_Spisok).Select
Last_Col = Cells(1, Columns.Count).End(xlToLeft).Column
Dim Sch(), Spis(), Town() As Variant
ReDim Sch(Last_Col), Spis(Last_Col, 1), Town(1, Last_Col)
Town = Range(Cells(1, 1), Cells(1, Last_Col))
Dim GR_LST, SCH_Town As Variant
stolb = 1
For ii = 1 To Last_Col
    Sch(ii) = Cells(2, 8).End(xlDown).Row - 1 'Sch(ii) = Cells(2, ii).End(xlDown).Row - 1
    Spis = Range(Cells(2, stolb), Cells(2 + Sch(ii), stolb))
    
    SCH_Town = 0
    ReDim GR_LST(1 To 1)
    For JJ = 1 To Sch(ii)
        fama = 0
        For kk = 1 To sch_lst
            If Spis(JJ, 1) = Name_Lst(kk) Then
               fama = 1
               index = kk
            End If
        Next 'kk
        If fama = 1 Then
           SCH_Town = SCH_Town + 1
           ReDim Preserve GR_LST(1 To SCH_Town)
           GR_LST(SCH_Town) = Sheets(index).Name
        End If
    Next 'jj
    PUT_FILE_out = PUT_FILE + Town(1, ii) + ".xlsx"
    Sheets(GR_LST).Copy
    ActiveWorkbook.SaveAs Filename:=PUT_FILE_out, FileFormat:=xlOpenXMLWorkbook
    ActiveWindow.Close
    stolb = stolb + 1
Next 'ii

'MsgBox "ГОТОВО"
'Application.ScreenUpdating = 1
'Application.DisplayAlerts = 1
End Sub

Sub Mailing()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim asTo, asSubject, asBody, asAttachment

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon

    asTo = Range("B2:B57").Value
    asSubject = Range("C2:C57").Value
    asBody = Range("D2:D57").Value
    asAttachment = Range("E2:E57").Value

    For i = 1 To UBound(asTo, 1)
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        With OutMail
            .To = asTo(i, 1)
            .Subject = asSubject(i, 1)
            .body = asBody(i, 1)
            .Attachments.Add asAttachment(i, 1)
            .Display 'Send
        End With
        On Error GoTo 0
        Set OutMail = Nothing
    Next i

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub