1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

Solved: Copy rows and header into new workbook and email

Discussion in 'Business Applications' started by skybuck, Jan 9, 2011.

Thread Status:
Not open for further replies.
Advertisement
  1. skybuck

    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.
     
  2. Rollin_Again

    Rollin_Again

    Joined:
    Sep 4, 2003
    Messages:
    4,912
    There is no attachment

    Rollin
     
  3. skybuck

    skybuck Thread Starter

    Joined:
    Jan 7, 2011
    Messages:
    28
    sorry, workbook attached. Thanks!
     

    Attached Files:

  4. Rollin_Again

    Rollin_Again

    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
     
  5. skybuck

    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?
     
  6. Rollin_Again

    Rollin_Again

    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
     
  7. skybuck

    skybuck Thread Starter

    Joined:
    Jan 7, 2011
    Messages:
    28
    the email addresses are listed on the tab "email addresses"
     
  8. skybuck

    skybuck Thread Starter

    Joined:
    Jan 7, 2011
    Messages:
    28
    i have some explanation on the first tab when you open the spreadsheet up.....
     
  9. Rollin_Again

    Rollin_Again

    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
     
  10. skybuck

    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!
     

    Attached Files:

  11. Rollin_Again

    Rollin_Again

    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
     
  12. skybuck

    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!
     
  13. skybuck

    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.
     

    Attached Files:

  14. Rollin_Again

    Rollin_Again

    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
     
  15. skybuck

    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.
     
  16. Sponsor

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 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/973663

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice