Solved: Copy rows and header into new workbook and email

Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

skybuck

Thread Starter
Joined
Jan 7, 2011
Messages
28
Hi, I need an excel Macro that will copy the rows (including the header) and paste into a new Workbook and then attach the workbook to Outlook email to send. It will need to add a message in the body of the email and add the email addresses. I have included a sample workbook to review.
Thank you for you help.
 
Joined
Sep 4, 2003
Messages
4,912
Do you want to copy the entire sheet to a new workbook and then email or only the rows that are visible after the autofilter is performed?

Rollin
 

skybuck

Thread Starter
Joined
Jan 7, 2011
Messages
28
I want to copy just the rows for each of the Make and then email them as an attachment....does that answer your question?
 
Joined
Sep 4, 2003
Messages
4,912
Where is the email address going to come from and is there going to be a different recipient for each of the different makes?

Rollin
 

skybuck

Thread Starter
Joined
Jan 7, 2011
Messages
28
i have some explanation on the first tab when you open the spreadsheet up.....
 
Joined
Sep 4, 2003
Messages
4,912
Try the code below. Just change the portion in red to reflect the correct directory to save the files to.

Code:
Sub Sort_By_Make()

On Error Resume Next

 Dim objOutlook As Object
 Dim Mail As Object

vName = ActiveWorkbook.Name
vSheet = ActiveSheet.Name

Columns("A:E").Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row

vStart = i

Do Until Workbooks(vName).Sheets(vSheet).Range("D" & i).Value <> Range("D" & i + 1).Value
i = i + 1
Loop

Workbooks.Add
vNewBook = ActiveWorkbook.Name

Workbooks(vName).Sheets(vSheet).Range("A1:E1").Copy Destination:=Workbooks(vNewBook).Sheets("Sheet1").Range("A1")

Workbooks(vName).Sheets(vSheet).Range("A" & vStart & ":E" & i).Copy Destination:=Workbooks(vNewBook).Sheets("Sheet1").Range("A2")

Cells.AutoFilter
Columns.EntireColumn.AutoFit
vPath = "C:\Test\" & Replace(Date, "/", "_") & " " & Workbooks(vName).Sheets(vSheet).Range("D" & i).Value & " 3rd Follow-up " & Replace(Time, ":", "_") & ".xlsm"
ActiveWorkbook.SaveAs (vPath)
vNewName = ActiveWorkbook.Name
Workbooks(vNewName).Close


    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .Subject = Replace(vNewName, ".xlsm", "")
             
             For j = 3 To Sheets("Email Addresses").Cells((Application.WorksheetFunction.Match((Workbooks(vName).Sheets(vSheet).Range("D" & i).Value), Sheets("Email Addresses").Range("A:A"), 0)), Columns.Count).End(xlToLeft).Column
      
      If Err.Number = 1004 Then
      For Each vTab In Sheets
      If vTab.Name = "Errors" Then
      vFound = True
      End If
      Next vTab
      
      If vFound <> True Then
      Sheets.Add.Name = "Errors"
      Sheets("Errors").Range("A1").Value = "NOT FOUND"
      End If
      Sheets("Errors").Range("A" & Sheets("Errors").Range("A" & Rows.Count).End(xlUp).Row + 1).Value = Workbooks(vName).Sheets(vSheet).Range("D" & i).Value
      Err.Clear
      GoTo Skip
      End If
      
       vNames = Workbooks(vName).Sheets("Email Addresses").Cells(Application.WorksheetFunction.Match(Workbooks(vName).Sheets(vSheet).Range("D" & i).Value, Workbooks(vName).Sheets("Email Addresses").Range("A:A"), 0), j).Value
      .Recipients.Add (vNames)
             Next j
        .attachments.Add vPath
        .Body = Workbooks(vName).Sheets("Email Addresses").Range("B" & Application.WorksheetFunction.Match(Workbooks(vName).Sheets(vSheet).Range("D" & i).Value, Workbooks(vName).Sheets("Email Addresses").Range("A:A"), 0)).Value
    End With
    
    objMail.display
    'objMail.Send
    
Skip:

    Set objMail = Nothing
    Set objOutlook = Nothing

Next i



End Sub

Rollin
Rollin
 

skybuck

Thread Starter
Joined
Jan 7, 2011
Messages
28
Hi Rollin,

Thanks for the code!
I got it to work and this is going to help out tremendously, thank you!

There are just a couple of things I need some help with:

- Getting an error when I go to open the attachment from the email
- if there is no email address found from the email addresses tab - it stops - can we have it continue and then at the end give me a list of which Makes did not have an email address to go with it?
- Does not add the 4th email address if there is one - I tried a couple different things and they didn't work.
- if there is a spreadsheet already in C:/Test the code asks if you want to replace it -instead of replacing it can we add a number to it - for example:

if there is one called "1_14_2011 Chevy 3rd Follow-up" can we call the next one "1_14_2011 Chevy 3rd Follow-up_2" and if there is a _2 can we call the next one _3 and so forth?

- if you click "No" to replace the workbook you get the error:

for example : "No Match Found for Honda on Email Address sheet"
Can we make it so that error does not show up if you click "No" to replace the existing workbook?

This code is great! Your help is much appreciated!
 

Attachments

Joined
Sep 4, 2003
Messages
4,912
I've updated the code below.

I believe the reason you couldn't open the workbook from email was because it was being saved with the wrong extension (.xls instead of .xlsm. This has been corrected so I believe it should now work. I've also modified the code so that the workbook will be saved with both the date and time appended to it so that each workbook name will be unique. Any of the vehicle makes that don't contain a match on the email tab will now be saved to a new sheet called "Errors"

Code:
Sub Sort_By_Make()

On Error Resume Next

 Dim objOutlook As Object
 Dim Mail As Object

vName = ActiveWorkbook.Name
vSheet = ActiveSheet.Name

Columns("A:E").Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row

vStart = i

Do Until Workbooks(vName).Sheets(vSheet).Range("D" & i).Value <> Range("D" & i + 1).Value
i = i + 1
Loop

Workbooks.Add
vNewBook = ActiveWorkbook.Name

Workbooks(vName).Sheets(vSheet).Range("A1:E1").Copy Destination:=Workbooks(vNewBook).Sheets("Sheet1").Range("A1")

Workbooks(vName).Sheets(vSheet).Range("A" & vStart & ":E" & i).Copy Destination:=Workbooks(vNewBook).Sheets("Sheet1").Range("A2")

Cells.AutoFilter
Columns.EntireColumn.AutoFit
vPath = "[COLOR="Red"]C:\Test[/COLOR]\" & Replace(Date, "/", "_") & " " & Workbooks(vName).Sheets(vSheet).Range("D" & i).Value & " 3rd Follow-up " & Replace(Time, ":", "_") & ".xlsm"
ActiveWorkbook.SaveAs (vPath)
vNewName = ActiveWorkbook.Name
Workbooks(vNewName).Close


    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    With objMail
        .Subject = Replace(vNewName, ".xlsm", "")
             
             For j = 3 To Sheets("Email Addresses").Cells((Application.WorksheetFunction.Match((Workbooks(vName).Sheets(vSheet).Range("D" & i).Value), Sheets("Email Addresses").Range("A:A"), 0)), Columns.Count).End(xlToLeft).Column
      
      If Err.Number = 1004 Then
      For Each vTab In Sheets
      If vTab.Name = "Errors" Then
      vFound = True
      End If
      Next vTab
      
      If vFound <> True Then
      Sheets.Add.Name = "Errors"
      Sheets("Errors").Range("A1").Value = "NOT FOUND"
      End If
      Sheets("Errors").Range("A" & Sheets("Errors").Range("A" & Rows.Count).End(xlUp).Row + 1).Value = Workbooks(vName).Sheets(vSheet).Range("D" & i).Value
      Err.Clear
      GoTo Skip
      End If
      
       vNames = Workbooks(vName).Sheets("Email Addresses").Cells(Application.WorksheetFunction.Match(Workbooks(vName).Sheets(vSheet).Range("D" & i).Value, Workbooks(vName).Sheets("Email Addresses").Range("A:A"), 0), j).Value
      .Recipients.Add (vNames)
             Next j
        .attachments.Add vPath
        .Body = Workbooks(vName).Sheets("Email Addresses").Range("B" & Application.WorksheetFunction.Match(Workbooks(vName).Sheets(vSheet).Range("D" & i).Value, Workbooks(vName).Sheets("Email Addresses").Range("A:A"), 0)).Value
    End With
    
    objMail.display
    'objMail.Send
    
Skip:

    Set objMail = Nothing
    Set objOutlook = Nothing

Next i



End Sub

Rollin
 

skybuck

Thread Starter
Joined
Jan 7, 2011
Messages
28
Thanks Rollin!
I will take a look at it this weekend. Been crazy busy at work!
 

skybuck

Thread Starter
Joined
Jan 7, 2011
Messages
28
Hi Rollin,

I changed the macro to sort by column C instead of D and I messed up the macro.
What I did was change all the "D" references in the macro to "C".

What happens now is that it does what it is supposed to do except that now if there are multiple rows with the same "make" it does not copy them together into 1 spreadsheet but rather separates them out into different spreadsheets and emails.

I tried to change the code without having to come back to you but, I didn't do a good job!
Your help is appreciated again if you can fix it for me.....

Sorry about this...once you fix this bug it should be good to go and I can close out this one...

Thanks again.
 

Attachments

Joined
Sep 4, 2003
Messages
4,912
Why exactly are you sorting by column C? If all the common makes are going to be put into the same destination worksheet why does it matter whether or not you sort by make?

Rollin
 

skybuck

Thread Starter
Joined
Jan 7, 2011
Messages
28
I had to switch the columns. The make used to be in D and i need it in column C.
 
Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

Users Who Are Viewing This Thread (Users: 0, Guests: 1)

As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 807,865 other people just like you!

Latest posts

Staff online

Top