VBA to email specific data from a table to multiple people

Sorry I thought I was really clear. I am not looking for people to "solving an entire project for me". I simply need to be able to have a code that when I click a button, it will create a new email for each account number and division within the account number that I have open on Sheet1. So in my example I have two accounts. The first account number is 6274. There are 6 different divisions currently open on the account - 1, 6, 9, 13, 11, 12. Therefore I need 6 emails created that list the items for that division (column E), the quantity on the order (column O), and the request (column X) listed in the body of the email. I suppose I will leave it there for now and see if we can come up with something. Thank you for the reply and please let me know if you would like me to clarify anything up.

Ok so there have been no hits so I either haven't explained what I am looking for properly, or it just isn't possible. Let me try to simplify it even more.

1. I have a data table that is on sheet1 and the range is A:X.
2. In column F there can be up to 6 different numbers - 1, 6, 9, 11, 12, and 13.
3. For each number that is listed I need an email created. So if only the number 1, 9, and 13 are listed, I need 3 emails created.
4. Continuing with the example of only having the number 1, 9, and 13 listed, the email that was created for the number 1 I would like all rows
that have the number 1 in column F to be put into the body of the email. All rows that have a 9 in column F should be put into the body of the email
created for the number 9. All rows that have a 13 in column F should be put into the body of the email created for the number 13.

Lets start there for now. And to be honest, at this point if someone is able to help me do this for just 1 number at a time that would be great.

I did not take offense to your reply. I tried to take your advice and break it down to a smaller request. Perhaps you are right and what I am asking would take too much time for someone else to come up with. I have been working the past two days on an answer for myself. Normally I spend hours on google prior to posting on here. I thought that this may be a simple request if I had only known the code however your response makes me think otherwise. Back to google I go.

I appreciate the tip. I have actually been trying to do just that. I have the below code I am using for each number but I have to create 6 different macros for each number. Is there anyway that in the Value position I can have it be the data in a specific cell rather than the number 1?

Sub Div1()
Dim RngColF As Range
Dim i As Range
Dim Dest As Range

Sheets("Email").Select
Set RngColF = Range("C11", Range("C" & Rows.Count).End(xlUp))

With Sheets("Email")
    Set Dest = .Range("A" & nxtColumn)
End With

For Each i In RngColF
    If i.Value = "1" Then
        Range(Cells(i.Row, 1).Address, Cells(i.Row, 10).Address).Copy Dest
        Set Dest = Dest.Offset(1, 0)
        Sheets("Email").Select
    End If
Next i
End Sub

Very easy to do but there are few layers . . if you want email code i'll add it below or just google it ron v brun i think his name is very good.


first things first

you'll need a loop down column "f" . . using a if statement to pull out the the item and copy to each number temp new sheet make sure you variable each sheet ( 1 = sht1 , 3 = sht3 etc ) .
once the a thru z is complete assign email each sheet out to its respective owner


I've made quite a few on these sheets up. they're very easy to do . . mind you my first one was quite a challenge but like mentioned earlier i could very easily throw it together but sounds like you want someone to do it all.

i will help you with the functions or line items, how very versed are you in VBA? can you handle coaching? It really helps when you break it all down into small steps. i.e. sort and create, distribute, then the glorious msgbox function saying its been done too the user.

Yeah sorry I didn't mean to offend anyone. I didn't realize how extensive my request was. I have realized it now and I posted just one step that I need help with at the moment. I am much much much better with formulas. Unfortunately when it comes to VBA I am able to follow along however creating my own from scratch is tough.

ok lets work this thru

step 1
your first step you want to create a new temp sheet for each location and assign it a variable

step 2
loop through column f and identify each number if number exist copy that line to its respective sheet

step 3

format your temp sheets so its pretty


step 4

email each sheet

step 5

delete each sheet




don't worry about nothing right now till you sort a sub to create a temp new sheet for each location



i have to goto work right now but ill help when i can

I appreciate the help! I have come up with everything up to Step 3. I will work on more of it tomorrow.

I have two macros that I will combine at the end. I did't want to add the macro that deletes the worksheets so I can see each step right now.

Sub Project_NewSheets()
    Application.ScreenUpdating = False
    Dim MyCell As Range, MyRange As Range
     
    Set MyRange = Sheets("Data").Range("AA2")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))

    For Each MyCell In MyRange
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = MyCell.Value
    Next MyCell
    
Sheets("Data").Select

Dim LR As Long, i As Long
With ActiveSheet
    LR = .Range("F" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        If .Range("F" & i).Value = "1" Then
            .Range("A" & i).Copy
            Sheets("Div. 1").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 1").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 1").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 1").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 1").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "6" Then
            .Range("A" & i).Copy
            Sheets("Div. 6").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 6").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 6").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 6").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 6").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "9" Then
            .Range("A" & i).Copy
            Sheets("Div. 9").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 9").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 9").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 9").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 9").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "11" Then
            .Range("A" & i).Copy
            Sheets("Div. 11").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 11").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 11").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 11").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 11").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "12" Then
            .Range("A" & i).Copy
            Sheets("Div. 12").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 12").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 12").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 12").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 12").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "13" Then
            .Range("A" & i).Copy
            Sheets("Div. 13").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 13").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 13").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 13").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 13").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
End With
End Sub

Sub Delete_Sheets()
Application.DisplayAlerts = False
Sheets("Div. 1").Delete
Sheets("Div. 6").Delete
Sheets("Div. 9").Delete
Sheets("Div. 11").Delete
Sheets("Div. 12").Delete
Sheets("Div. 13").Delete
End Sub

OK so I have figured out how to do it. Below are the 3 codes I am using. If I run them one at a time they work perfectly however when I try to run them together by either combining them or calling them the part that sends the emails does not work. The code is very sloppy since I had to learn how to do each step, but hopefully you will be able to read it. If someone could advise what could be causing the email part not to work when they are combined it would be greatly appreciated. I do not receive any error messages.

Sub Main()
    Application.ScreenUpdating = False
    Dim MyCell As Range, MyRange As Range
     
    Set MyRange = Sheets("Data").Range("AA2")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))

    For Each MyCell In MyRange
        Sheets.Add After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = MyCell.Value
    Next MyCell
    
Sheets("Data").Select

Dim LR As Long, i As Long
With ActiveSheet
    LR = .Range("F" & Rows.Count).End(xlUp).Row
    For i = 1 To LR
        If .Range("F" & i).Value = "1" Then
            .Range("A" & i).Copy
            Sheets("Div. 1").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 1").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 1").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 1").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 1").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
    
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "6" Then
            .Range("A" & i).Copy
            Sheets("Div. 6").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 6").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 6").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 6").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 6").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "9" Then
            .Range("A" & i).Copy
            Sheets("Div. 9").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 9").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 9").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 9").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 9").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "11" Then
            .Range("A" & i).Copy
            Sheets("Div. 11").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 11").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 11").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 11").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 11").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "12" Then
            .Range("A" & i).Copy
            Sheets("Div. 12").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 12").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 12").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 12").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 12").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
     LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "13" Then
            .Range("A" & i).Copy
            Sheets("Div. 13").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 13").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 13").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 13").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 13").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If
    Next i
End With

            With Sheets("Div. 1")
                .Columns("A:E").HorizontalAlignment = xlCenter
                .Columns("A:E").EntireColumn.AutoFit
            End With
            With Sheets("Div. 6")
                .Columns("A:E").HorizontalAlignment = xlCenter
                .Columns("A:E").EntireColumn.AutoFit
            End With
            With Sheets("Div. 9")
                .Columns("A:E").HorizontalAlignment = xlCenter
                .Columns("A:E").EntireColumn.AutoFit
            End With
            With Sheets("Div. 11")
                .Columns("A:E").HorizontalAlignment = xlCenter
                .Columns("A:E").EntireColumn.AutoFit
                End With
            With Sheets("Div. 12")
                .Columns("A:E").HorizontalAlignment = xlCenter
                .Columns("A:E").EntireColumn.AutoFit
                End With
            With Sheets("Div. 13")
                .Columns("A:E").HorizontalAlignment = xlCenter
                .Columns("A:E").EntireColumn.AutoFit
                End With


End Sub

Sub Send_Email()
'Working in Excel 2002-2016
    Dim Sendrng As Range

    On Error GoTo StopMacro

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
Sheets("Div. 1").Select

Range(Range("A1:E1"), Range("A1:E1").End(xlDown)).Select
    'Note: if the selection is one cell it will send the whole worksheet
    Set Sendrng = Selection

    'Create the mail and send it
    With Sendrng

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "Please advise if I may make the below moves/allocations."

            With .Item
                .To = ("I removed my email address")
                .CC = ""
                .BCC = ""
                .Subject = ("Division 1 Allocation Requests")
                .Send
            End With

        End With
    End With
    
Sheets("Div. 6").Select

Range(Range("A1:E1"), Range("A1:E1").End(xlDown)).Select
    'Note: if the selection is one cell it will send the whole worksheet
    Set Sendrng = Selection

    'Create the mail and send it
    With Sendrng

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "Please advise if I may make the below moves/allocations."

            With .Item
                .To = ("I removed my email address")
                .CC = ""
                .BCC = ""
                .Subject = ("Division 6 Allocation Requests")
                .Send
            End With

        End With
    End With
    
Sheets("Div. 9").Select

Range(Range("A1:E1"), Range("A1:E1").End(xlDown)).Select
    'Note: if the selection is one cell it will send the whole worksheet
    Set Sendrng = Selection

    'Create the mail and send it
    With Sendrng

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "Please advise if I may make the below moves/allocations."

            With .Item
                .To = ("I removed my email address")
                .CC = ""
                .BCC = ""
                .Subject = ("Division 9 Allocation Requests")
                .Send
            End With

        End With
    End With

Sheets("Div. 11").Select

Range(Range("A1:E1"), Range("A1:E1").End(xlDown)).Select
    'Note: if the selection is one cell it will send the whole worksheet
    Set Sendrng = Selection

    'Create the mail and send it
    With Sendrng

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "Please advise if I may make the below moves/allocations."

            With .Item
                .To = ("[email protected]")
                .CC = ""
                .BCC = ""
                .Subject = ("I removed my email address")
                .Send
            End With

        End With
    End With
    
Sheets("Div. 12").Select

Range(Range("A1:E1"), Range("A1:E1").End(xlDown)).Select
    'Note: if the selection is one cell it will send the whole worksheet
    Set Sendrng = Selection

    'Create the mail and send it
    With Sendrng

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "Please advise if I may make the below moves/allocations."

            With .Item
                .To = ("I removed my email address")
                .CC = ""
                .BCC = ""
                .Subject = ("Division 12 Allocation Requests")
                .Send
            End With

        End With
    End With

Sheets("Div. 13").Select

Range(Range("A1:E1"), Range("A1:E1").End(xlDown)).Select
    'Note: if the selection is one cell it will send the whole worksheet
    Set Sendrng = Selection

    'Create the mail and send it
    With Sendrng

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "Please advise if I may make the below moves/allocations."

            With .Item
                .To = ("I removed my email address")
                .CC = ""
                .BCC = ""
                .Subject = ("Division 13 Allocation Requests")
                .Send
            End With

        End With
    End With
StopMacro:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    ActiveWorkbook.EnvelopeVisible = False
End Sub

Sub Delete_Sheets()
Application.DisplayAlerts = False
Sheets("Div. 1").Delete
Sheets("Div. 6").Delete
Sheets("Div. 9").Delete
Sheets("Div. 11").Delete
Sheets("Div. 12").Delete
Sheets("Div. 13").Delete
End Sub

not sure how how well that code would work TBH it isnt making any sense to me i like to view things simplify

sub  new sheets ()


dim ws1, ws6,ws9,ws11,ws12,ws13 as worksheet


ws1 = Sheets.Add.Name = "supplier1"
ws6 = Sheets.Add.Name = "supplier6"
ws9 = Sheets.Add.Name = "supplier9"
ws11 = Sheets.Add.Name = "supplier11"
ws12= Sheets.Add.Name = "supplier12"
ws13 = Sheets.Add.Name = "supplier13"

i have to got work . . . will post again later tonight

For the new worksheets code I have the names I want each worksheet to be in column AA. The code uses the data in column AA as the new sheet names. But I know for a fact each code I listed works. When I run them one at a time the process goes 100% as I need it to. But when I call them all together, or combine them, the sending of the emails does not happen. It appears as though it simply skips the code.

This is edited email code from ron V bruin Best code ive found that really works well.


if its alway the same email if code it in and use a dry loop through each sheet

'THIS 

LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "6" Then
            .Range("A" & i).Copy
            Sheets("Div. 6").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("B" & i).Copy
            Sheets("Div. 6").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("E" & i).Copy
            Sheets("Div. 6").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("O" & i).Copy
            Sheets("Div. 6").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
            .Range("X" & i).Copy
            Sheets("Div. 6").Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
        End If

'Becomes this

'instead of finding last row each time  use 1 variable and add each time you use like below

dim sht6 as worksheet
dim finalrow6 as integer

set sht6 = sheets("Div. 6")

LR = .Range("F" & Rows.Count).End(xlUp).Row
     For i = 1 To LR
        If .Range("F" & i).Value = "6" Then
            .range ("A" & i  & ", b" & i & ",E" & i &",O" & i & ",x" & i ).Copy
           sht6.cells("1" & finalrow6).PasteSpecial Paste:=xlPasteValues
           finalrow6 = finalrow6 +1
       End If


Also using a CASE logic will shrink your code down even further

If MsgBox("Are you sure you want to send Email now?", vbYesNo) = vbYes Then


    Set Sourcewb = ActiveWorkbook

    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2013
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "email addresses here"
            '.To = "emailaddresshere or vairable with them all"
            .cc = ""
            .BCC = BCCemail
            .Subject = "subject here"
            .Body = emailbody
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing
    Set Sourcewb = Nothing
    Set Destwb = Nothing
    
    Sheets("console").Select
   

   With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    MsgBox ("Email had been sent!" & vbNewLine & " " & vbNewLine & "Have a great Day!")

Else

MsgBox ("Email Not Sent")
Sheets("whatever sheet you want here").Select

With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End If