VBA to Split data into several reports and email via outlook

Hello VBA Expers and novices, and everyone in between

Six months ago I startet looking into VBA, and this forum basically taught me all I know of VBA
I have always been able to find answers here.. However here is my first post on a problem I can’t solve on my own or seem to read the answer to.

Here is the case:

I am extracting data from a excel file and then I am arranging the data in my own excel file. My own excel file contains “contracts” - each line in this sheet contains a contract. Within the line I have all the information needed. I want to create several reports with contracts - they have to be split depending on who owns the contract. The contract owner is defined within each line of the data. The “contract owner” can have multiple contracts so I need to sort the reports so that each "contract owner" only gets 1 email with and attachment with 1 excel file with all his contracts.

So basically I want to split my excel file into several reports depending on a certain criteria (cell value = contract owner).

And… I basically created a code that does all this for me.. however I need to tweak the code.
This is important, as you can see in my code, it is long and depending on the names within the VBA code are correct.
(Right now i have 46 owners and 250 contracts, so i would have to doublicate the code below 46 times!!).
Further I am possiblely not the one to maintain the VBA code - so when contract owners change (promted/hired/fired) the code needs to be update manually.. which is a huge pitfall. (or impossible with the code in its current form).

This is were you come in! There are so many experts out there, I am sure one of you can crack this case – and enlighten me

Sub splitnsend()

    'Here i select the first contract owner
    Selection.AutoFilter Field:=14, Criteria1:="Bill Gates"
    Columns("A:O").Select
    Selection.Copy
    
    'creating a new workbook that will serve as report (later to be emailed to bill)
    Workbooks.Add
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Application.CutCopyMode = False
    Selection.Interior.ColorIndex = xlNone
    
    'following code is the report on Bills active contracts
    '' THE FOLLOWING IS CREATING THE REPORT
    Range("A1").Select
    RowCount = ActiveCell.CurrentRegion.Rows.Count
    
    ActiveCell.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    
    ActiveCell.Offset(2, 0).FormulaR1C1 = "Total Contract Value (SEK)"
    ActiveCell.Offset(3, 0).FormulaR1C1 = "Total Commitment (SEK)"
    
    ActiveCell.Offset(2, 1).FormulaR1C1 = "=SUM(OFFSET(R1C3,0,0,COUNTA(C3),1))"
    ActiveCell.Offset(3, 1).FormulaR1C1 = "=SUM(OFFSET(R1C4,0,0,COUNTA(C4),1))"
    
    ActiveCell.Offset(3, 1).Select
    ActiveCell.CurrentRegion.Select
    Selection.Style = "Comma"
    Selection.NumberFormat = "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
    
    Selection.Font.Bold = True
    Range("A1").Select
    ''REPORT DONE - TIME TO EMAIL:

    Range("O2").Select 'selecting range for emailaddress
    
    'Defining stuff for email
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim email_ As String
    Dim subject_ As String
    Dim body_ As String
    Dim rCell As Range
    Dim EmailStr As String

     'Create  Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
     'Create list of emails from selected cells
     'THIS is a code is what i use to define my "to" (this case bill)
     'I KNOW this is not what the code originally intended to do.. it was
     'designed to create a list of emailaddresses (from a selected range)
    For Each rCell In Selection.Cells
        EmailStr = EmailStr + rCell & ";"
    Next rCell
    
    'save attachment
    'I need to save the workbook i am gonna report in order to give it the name i want
    ActiveWorkbook.SaveAs Filename:= _
        Environ$("temp") & "\" & ActiveWorkbook.ActiveSheet.Range("N2").Value & "'s" & " " & "Consultant Report" & ".xls" _
        , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
         
    email_ = EmailStr
    subject_ = "Consultant Contract Report"
    body_ = "Hello, Attached you find a report of your currently active contracts"
    
     'Create Mail Item and send it
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
        .To = email_
        .Subject = subject_
        .Attachments.Add ActiveWorkbook.FullName
        .Body = body_
        .Display
    End With
    
    ActiveWorkbook.Close
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    
    Windows("Split and send.xls").Activate
    Sheets("Sheet1").Select
    Selection.AutoFilter Field:=14
    
    '**** NEW OWNER****
    ' THEN I START ALL OVER WITH STEVE's CONTRACTS
    ' I HAVE 46 contract owners in my orignial datas
    ' I really hope there is a better way - or it is gonna be
    ' a long a vounaruble code
    Selection.AutoFilter Field:=14, Criteria1:="Steve Jobs"
    Columns("A:O").Select
    Selection.Copy
    
    Workbooks.Add
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Application.CutCopyMode = False
    Selection.Interior.ColorIndex = xlNone
    
    Range("A1").Select
    RowCount = ActiveCell.CurrentRegion.Rows.Count
    
    ActiveCell.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    
    ActiveCell.Offset(2, 0).FormulaR1C1 = "Total Contract Value (SEK)"
    ActiveCell.Offset(3, 0).FormulaR1C1 = "Total Commitment (SEK)"
    
    ActiveCell.Offset(2, 1).FormulaR1C1 = "=SUM(OFFSET(R1C3,0,0,COUNTA(C3),1))"
    ActiveCell.Offset(3, 1).FormulaR1C1 = "=SUM(OFFSET(R1C4,0,0,COUNTA(C4),1))"
    
    ActiveCell.Offset(3, 1).Select
    ActiveCell.CurrentRegion.Select
    Selection.Style = "Comma"
    Selection.NumberFormat = "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
    
    Selection.Font.Bold = True
    Range("A1").Select
    
    Range("O2").Select
    
     'Create  Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
     'Create list of emails from selected cells
    For Each rCell In Selection.Cells
        EmailStr = EmailStr + rCell & ";"
    Next rCell
    
    'save attachment
    ActiveWorkbook.SaveAs Filename:= _
        Environ$("temp") & "\" & ActiveWorkbook.ActiveSheet.Range("N2").Value & "'s" & " " & "Consultant Report" & ".xls" _
        , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
         
    email_ = EmailStr
    subject_ = "Consultant Contract Report"
    body_ = "Hello, Attached you find a report of your currently active contracts"
    
     'Create Mail Item and send it
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
        .To = email_
        .Subject = subject_
        .Attachments.Add ActiveWorkbook.FullName
        .Body = body_
        .Display
    End With
    
    ActiveWorkbook.Close
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    
    Windows("Split and send.xls").Activate
    Sheets("Sheet1").Select
    Selection.AutoFilter Field:=14
    
     '**** NEW OWNER****
     ' STARTING OVER AGAIN *SIGH* :)
    'Selection.AutoFilter Field:=14, Criteria1:="Steve Jobs"
    '.............
    '.......
    '....
    '...

Hope to see some inputs - thank you in advace. Peace out!

(Before you suggest I put this into Access I have to add that I know nothing of Access and my department insists to keep our database as an excel-sheet until a proper contract management system is in place)

//Skjoldborg
VBA student