Set Filter and email file

I need to filter my worksheet and then email it. But I need to loop through this based on a list of sales reps on another tab. I have a list of 9 sales reps with their email addresses and sales rep codes. I need to filter column F (Sales Rep Code) for each of the sales reps code, save the file, then send it to that rep. Then repeat that for each rep in the list.
LVL 1
Lawrence SalvucciInformation Technology ManagerAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
You can use a pivot table to make sheets for everyone.  
 
Make the pivot table with Sales Rep in the FILTERS area, and whatever else you want on the Pivot table.
Click on the dropdown box that says (All) in the filter, but you don't need to drop the list.
Click on the PIVOTTABLE TOOLS, ANALYZE ribbon
Drop the choices for Options in the PivotTable group
Choose "Show Report Filter Pages"
Like magic, this will create separate worksheets for everyone :)

once the sheets are made, you can Ctrl-A to select all on each sheet, copy and paste special, values to convert the pivot tables to regular cells
 
Then you can use Excel to email a sheet.  Add the "Send to Mail Recipient" icon to your QAT.
This option lets you email an entire workbook or just a sheet.

I realize you were probably hoping for code ... but I didn't have a sample workbook to create the code for you
0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
I would prefer to stay away from pivot tables to be honest. I can post a sample of what I'm looking to have done shortly.
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
Hi Lawrence,

that would be great! I'd be happy to take a look and give you code to do things in a better way

The email addresses don't have to work, of course ...  just need to see where they are
0
Cloud Class® Course: C++ 11 Fundamentals

This course will introduce you to C++ 11 and teach you about syntax fundamentals.

Lawrence SalvucciInformation Technology ManagerAuthor Commented:
Hi....Here's a sample file. In column F is where the rep codes are. There is a separate tab for the codes and the corresponding emails for each code. So what I need done is filter column F to the first code and then save the file and email it to that rep. Then filter the second code and email it to that rep, etc, etc. But there code might not always be at the start of column F. There could be more than 1 rep assigned to an account so you will see something like S-T in that column. So records like that will go to both reps when the emails are sent. So the filter will need to be set to "Contains" and then the letter code so it picks it up no matter where it is in the cell itself. There are some codes that will show like this: Q-Q which means they are the primary and secondary on that particular account. So those records would just go to that one rep. I hope this makes sense.
Sample-File.xlsx
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
got it, thanks -- I will whip some code up for you ~ stay tuned in case I have questions.  Thanks, Lawrence
0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
Thank you VERY MUCH!!!! :)
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
here you go

Option Explicit

Sub LoopAndEmail()
'strive4peace 151115
   On Error GoTo Proc_Err
   
   Dim wbData As Workbook
   Dim wsData As Worksheet
   Dim wsEmail As Worksheet
   
   Dim wbTarget As Workbook
   Dim wsTarget As Worksheet
   
   Dim rngToFilter As Range
   
   Dim outApp As Object
   Dim outMsg As Object
   
   Dim nRowData1 As Long
   Dim nRowData2 As Long
   Dim nRowEmail1 As Long
   Dim nRowEmail2 As Long
   
   Dim nRow As Long
   Dim sPathFile As String
   Dim sRepCode As String
   Dim sEmail As String
   
   Dim nRowsFilteredData As Long
   Dim iCountSent As Integer
   Dim sMsg As String
   
   Set outApp = CreateObject("Outlook.Application")
   
   iCountSent = 0
   
   Set wbData = ActiveWorkbook
   Set wsData = wbData.Sheets("Customer Sales")
   Set wsEmail = wbData.Sheets("Rep Codes")
   'get last row of data and set range to filter
   With wsData
      .Select
      .Cells(1, 1).Select
      nRowData1 = 1
      nRowData2 = .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp=-4162
      Set rngToFilter = .Range(.Cells(nRowData1, 1), .Cells(nRowData2, 6))
      'clear filters
      On Error Resume Next
      .ShowAllData
      On Error GoTo Proc_Err
   End With
   
   'get first and last row of rep email info
   With wsEmail
      .Select
      nRowEmail1 = 2
      nRowEmail2 = .Cells(.Rows.Count, 2).End(-4162).Row 'xlUp=-4162
   End With
   
   'loop through reps
   For nRow = nRowEmail1 To nRowEmail2
      'if email address is not specified, then skip this row
      If wsEmail.Cells(nRow, 2) <> "" Then
         'email address is specified
         sRepCode = wsEmail.Cells(nRow, 1)
         sEmail = wsEmail.Cells(nRow, 2)
         sPathFile = ActiveWorkbook.Path _
         & "\Rep_" & sRepCode & "_" & Format(Date, "yymmdd") & ".xlsx"
         
         'if file already exists, then delete it
         If Len(Dir(sPathFile)) > 0 Then
            Kill sPathFile
            DoEvents
         End If
                           
         'go back to the data workbook
         wbData.Activate
         'switch to Data Sheet
         With wsData
            .Select
         
            'filter the information
            rngToFilter.AutoFilter Field:=6 _
               , Criteria1:="=*" & sRepCode & "*" _
               , Operator:=xlAnd
            'copy the visible cells
            .Range("A1").Select
            'see how many rows are in the filtered data
            nRowsFilteredData = .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp=-4162
         End With 'wsData

         'if there is data
         If nRowsFilteredData > 1 Then
            'select the cells
            Selection.CurrentRegion.Select
            Selection.Copy
            
            'Add  workbook
            Set wbTarget = Workbooks.Add
            Set wsTarget = ActiveSheet
            
            'copy values to Target Sheet
            With wsTarget
               .Paste
               'best-fit columns
               .Columns("A:F").EntireColumn.AutoFit
               'format headings
               With Range(.Cells(1, 1), .Cells(1, 6))
                  .Interior.Color = RGB(255, 255, 153)
                  .HorizontalAlignment = xlCenter
               End With
               'freeze panes
               .Range("A2").Select
               ActiveWindow.FreezePanes = True
               
            End With
            'save and close workbook
            wbTarget.Close True, sPathFile
            'email workbook ------------------------ customize message
            sMsg = "Hello, " _
               & vbCrLf & vbCrLf & "Your workbook is attached"
               
            Set outMsg = outApp.CreateItem(0) '0=olMailItem
            'outMsg.Importance = olImportanceHigh
            outMsg.To = sEmail
            'outMsg.CC = "CC EMAIL ADDRESS GOES HERE"
            'outMsg.BCC = "BCC EMAIL ADDRESS GOES HERE"
            outMsg.Subject = "Workbook attached: " & sRepCode '------------- customize
            outMsg.Body = sMsg
            outMsg.Attachments.Add sPathFile
            ' If you want to edit the message then uncomment Display and comment Send
            'outMsg.Display
            outMsg.Send
            
            iCountSent = iCountSent + 1
                        
         End If 'has filtered data
         
      End If 'has an email address
      
   Next nRow
   
   With wsData
      .Select
      .Cells(1, 1).Select
      'clear filters
      On Error Resume Next
      .ShowAllData
      On Error GoTo Proc_Err
   End With

   MsgBox "Done emailing " & iCountSent & " workbooks", , "Done"
   
Proc_Exit:
   On Error Resume Next
   'release object variables
   Set rngToFilter = Nothing
   Set wsTarget = Nothing
   Set wsData = Nothing
   Set wsEmail = Nothing
   Set wbData = Nothing
   Set wbTarget = Nothing
   Set outMsg = Nothing
   Set outApp = Nothing
   Exit Sub
  
Proc_Err:
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   SendToDB"

   Resume Proc_Exit
   Resume
End Sub

Open in new window


if you don't use Outlook, let me know and I will do the email differently
0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
Wow, you're quick! I actually don't use outlook. I use CDO to email the files. Here's the code I use just in case you need it.


    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'Send the message using the network (SMTP over the network)
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'Basic (clear-text) authentication. 0 Do not authenticate
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Reports@gmail.com" 
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False 'Use SSL for the connection (True or False)
        .Update
    End With

    With iMsg
        Set .Configuration = iConf
        .To = "jtegg@gmail.com"
        .BCC = "lsalvucci@gmail.com"
        .From = """Reports"" <Reports@gmail.com>"
        .Subject = "Daily Open Orders Report - JBT"
        .TextBody = "As Of " & Date
        .AddAttachment "\\bcar1\bcar-net\IT\Excel Spreadsheets\Daily Open Orders Report - V.xlsx"
        .Send
    End With

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

Open in new window

0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
try this:

Option Explicit

Sub LoopAndEmail()
'strive4peace 151115
'
   'ASSUMPTION
   '  the ActiveWorkbook will contain sheets called:
   '     Customer Sales
   '     Rep Codes -- if no email address is specified, rep will be skipped
   '  path is: "\\bcar1\bcar-net\IT\Excel Spreadsheets\"
   
   'CALLS
   '  emailCDOAttachment
   
   On Error GoTo Proc_Err
   
   Dim wbData As Workbook
   Dim wsData As Worksheet
   Dim wsEmail As Worksheet
   
   Dim wbTarget As Workbook
   Dim wsTarget As Worksheet
   
   Dim rngToFilter As Range
   
   Dim outApp As Object
   Dim outMsg As Object
   
   Dim nRowData1 As Long
   Dim nRowData2 As Long
   Dim nRowEmail1 As Long
   Dim nRowEmail2 As Long
   
   Dim nRow As Long
   Dim sPathFile As String
   Dim sRepCode As String
   Dim sEmail As String
   
   Dim nRowsFilteredData As Long
   Dim iCountSent As Integer
   Dim sFilename As String
   Dim sMsg As String
     
   iCountSent = 0
   
   Set wbData = ActiveWorkbook
   Set wsData = wbData.Sheets("Customer Sales")
   Set wsEmail = wbData.Sheets("Rep Codes")
   'get last row of data and set range to filter
   With wsData
      .Select
      .Cells(1, 1).Select
      nRowData1 = 1
      nRowData2 = .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp=-4162
      Set rngToFilter = .Range(.Cells(nRowData1, 1), .Cells(nRowData2, 6))
      'clear filters
      On Error Resume Next
      .ShowAllData
      On Error GoTo Proc_Err
   End With
   
   'get first and last row of rep email info
   With wsEmail
      .Select
      nRowEmail1 = 2
      nRowEmail2 = .Cells(.Rows.Count, 2).End(-4162).Row 'xlUp=-4162
   End With
   
   'loop through reps
   For nRow = nRowEmail1 To nRowEmail2
      'if email address is not specified, then skip this row
      If wsEmail.Cells(nRow, 2) <> "" Then
         'email address is specified
         sRepCode = wsEmail.Cells(nRow, 1)
         sEmail = wsEmail.Cells(nRow, 2)
         sFilename = "Daily Open Orders Report - " & sRepCode & "_" & Format(Date, "yymmdd") & ".xlsx"
         sPathFile = "\\bcar1\bcar-net\IT\Excel Spreadsheets\" & sFilename
         
         'if file already exists, then delete it
         If Len(Dir(sPathFile)) > 0 Then
            Kill sPathFile
            DoEvents
         End If
                           
         'go back to the data workbook
         wbData.Activate
         'switch to Data Sheet
         With wsData
            .Select
         
            'filter the information
            rngToFilter.AutoFilter Field:=6 _
               , Criteria1:="=*" & sRepCode & "*" _
               , Operator:=xlAnd
            'copy the visible cells
            .Range("A1").Select
            'see how many rows are in the filtered data
            nRowsFilteredData = .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp=-4162
         End With 'wsData

         'if there is data
         If nRowsFilteredData > 1 Then
            'select the cells
            Selection.CurrentRegion.Select
            Selection.Copy
            
            'Add  workbook
            Set wbTarget = Workbooks.Add
            Set wsTarget = ActiveSheet
            
            'copy values to Target Sheet
            With wsTarget
               .Paste
               'best-fit columns
               .Columns("A:F").EntireColumn.AutoFit
               'format headings
               With Range(.Cells(1, 1), .Cells(1, 6))
                  .Interior.Color = RGB(255, 255, 153)
                  .HorizontalAlignment = xlCenter
               End With
               'freeze panes
               .Range("A2").Select
               ActiveWindow.FreezePanes = True
               
            End With
            'save and close workbook
            wbTarget.Close True, sPathFile
            
            'email workbook ------------------------ customize message
            sMsg = "Hello, " _
               & vbCrLf & vbCrLf & "Daily Open Orders Report is attached for " & sRepCode _
                  & " as of " & Date

            Call emailCDOAttachment(sEmail, sPathFile, sMsg, sFilename)
            
            iCountSent = iCountSent + 1
                        
         End If 'has filtered data
         
      End If 'has an email address
      
   Next nRow
   
   With wsData
      .Select
      .Cells(1, 1).Select
      'clear filters
      On Error Resume Next
      .ShowAllData
      On Error GoTo Proc_Err
   End With

   MsgBox "Done emailing " & iCountSent & " workbooks", , "Done"
   
Proc_Exit:
   On Error Resume Next
   'release object variables
   Set rngToFilter = Nothing
   Set wsTarget = Nothing
   Set wsData = Nothing
   Set wsEmail = Nothing
   Set wbData = Nothing
   Set wbTarget = Nothing
   Exit Sub
  
Proc_Err:
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   SendToDB"

   Resume Proc_Exit
   Resume
End Sub

Sub emailCDOAttachment(ByVal psEmail As String _
   , ByVal psPathFile As String _
   , ByVal psMsg As String _
   , ByVal psSubject As String)

    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'Send the message using the network (SMTP over the network)
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'Basic (clear-text) authentication. 0 Do not authenticate
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Reports@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False 'Use SSL for the connection (True or False)
        .Update
    End With

    With iMsg
        Set .Configuration = iConf
        .To = psEmail
        .BCC = "lsalvucci@gmail.com"
        .From = """Reports"" <Reports@gmail.com>"
        .Subject = psSubject  '"Daily Open Orders Report - JBT"
        .TextBody = psMsg  '"As Of " & Date
        .AddAttachment psPathFile  '"\\bcar1\bcar-net\IT\Excel Spreadsheets\Daily Open Orders Report - V.xlsx"
        .Send
    End With

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

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
You're good! :) Just a couple of followup questions...

1. If I was to add a couple of columns on the "Rep Codes" tab to add their names, what would I need to do to your code? I want to add their first name and last name in separate columns to the left of the code. So the code column would shift to column C.

2. If I added a couple of rows about the header row on the "Customer Sales" tab, what would I need to change in your code? I may want to put totals above the headers so I may shift the header column down to row 3.

Thank you again for all your help! You truly are amazing! And quick!!
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
thank you, Lawrence ~

1.  change these statements:
      If wsEmail.Cells(nRow, 2) <> "" Then
         'email address is specified
         sRepCode = wsEmail.Cells(nRow, 1)
         sEmail = wsEmail.Cells(nRow, 2)

Open in new window


1 is the column number for the rep
2 is the column number for email

2.  change these statements:
   With wsData
      .Select
      .Cells(1, 1).Select
      nRowData1 = 1
      nRowData2 = .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp=-4162
      Set rngToFilter = .Range(.Cells(nRowData1, 1), .Cells(nRowData2, 6))

Open in new window


.Cells(1, 1).Select  -- should be the upperleft cell that the labels start on
nRowData1 = whatever row your labels are on

... and I think that might be it ~ unless you also want to copy the additional header rows to the target sheet, in which case there is more
0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
Thank you for the quick answers. I'm thinking maybe I want to copy the additional 3 rows I just added above the header row with everything else. I should have added this before I sent the sample file and I apologize for that. I added 3 rows above the header row so now the headers are in row 4. But I want to copy those as well. So what will I need to change? I haven't made any of your changes to my prior second question. I did make the changes to the "Rep Codes" tab and everything looks good there.
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
give me a few minutes, I will make more stuff variable ~
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
I just changed the first procedure.  Can't test it though since I don't have your CDO settings.  Hopefully it works ok! Please backup your file before you replace the code and run it.

If you get an error when you run:

press Ctrl-C to copy the error message and paste into a message back to me

press Ctrl-Break and choose Debug when prompted (you may have to OK the message first)

right-click on the statement at the bottom that says Resume
and choose -- Set Next Statement

press F8 to execute and go back to the bad line

tell me where you are ~

Sub LoopAndEmail()
'strive4peace 151115
'
   'ASSUMPTION
   '  the ActiveWorkbook will contain sheets called:
   '     Customer Sales -- assume column 1 is the first column of data
   '     Rep Codes -- if no email address is specified, rep will be skipped
   '  path is: "\\bcar1\bcar-net\IT\Excel Spreadsheets\"
   
   'CALLS
   '  emailCDOAttachment
   
   On Error GoTo Proc_Err
   
   Dim wbData As Workbook
   Dim wsData As Worksheet
   Dim wsEmail As Worksheet
   
   Dim wbTarget As Workbook
   Dim wsTarget As Worksheet
   
   Dim rngToFilter As Range
   
   Dim outApp As Object
   Dim outMsg As Object
   
   Dim nRowDataHeader As Long
   Dim nRowDataLabels As Long
   Dim nRowData2 As Long
   Dim nNumColsData As Long
   Dim nColData_Rep As Long
   
   Dim nRowEmail1 As Long
   Dim nRowEmail2 As Long
   Dim nColRepCodes_Rep As Long
   Dim nColRepCodes_Email As Long
   
   Dim nRow As Long
   Dim sPathFile As String
   Dim sRepCode As String
   Dim sEmail As String
   
   Dim nRowsFilteredData As Long
   Dim iCountSent As Integer
   Dim sFilename As String
   Dim sMsg As String
     
'-------------------------------------------------------------------------
   nRowDataHeader = 1 'first row of headings to copy -- same as Data Labels if there aren't any
   nRowDataLabels = 4 'if this is the same, there are currently no header rows above it
   nColData_Rep = 6 'column with Rep Code on the Data sheet
   nNumColsData = 6 'number of columns of data to copy
   
   nRowEmail1 = 2 'first row of rep code and email on Rep Codes sheet
   nColRepCodes_Rep = 1 'column for rep code on Rep Codes sheet
   nColRepCodes_Email = 2 'column for email on Rep Codes sheet
'-------------------------------------------------------------------------

   iCountSent = 0
   
   Set wbData = ActiveWorkbook
   Set wsData = wbData.Sheets("Customer Sales")
   Set wsEmail = wbData.Sheets("Rep Codes")
   'get last row of data and set range to filter
   With wsData
      .Select
      .Cells(nRowDataLabels, 1).Select
      nRowData2 = .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp=-4162
      Set rngToFilter = .Range(.Cells(nRowDataLabels, 1), .Cells(nRowData2, nNumColsData))
      'clear filters
      On Error Resume Next
      .ShowAllData
      On Error GoTo Proc_Err
   End With
   
   'get first and last row of rep email info
   With wsEmail
      .Select
      nRowEmail2 = .Cells(.Rows.Count, nColRepCodes_Email).End(-4162).Row 'xlUp=-4162
   End With
   
   'loop through reps
   For nRow = nRowEmail1 To nRowEmail2
      'if email address is not specified, then skip this row
      If wsEmail.Cells(nRow, nColRepCodes_Email) <> "" Then
         'email address is specified
         sRepCode = wsEmail.Cells(nRow, nColRepCodes_Rep)
         sEmail = wsEmail.Cells(nRow, nColRepCodes_Email)
         sFilename = "Daily Open Orders Report - " & sRepCode & "_" & Format(Date, "yymmdd") & ".xlsx"
         sPathFile = "\\bcar1\bcar-net\IT\Excel Spreadsheets\" & sFilename
         
         'if file already exists, then delete it
         If Len(Dir(sPathFile)) > 0 Then
            Kill sPathFile
            DoEvents
         End If
                           
         'go back to the data workbook
         wbData.Activate
         'switch to Data Sheet
         With wsData
            .Select
            'filter the information
            rngToFilter.AutoFilter Field:=nColData_Rep _
               , Criteria1:="=*" & sRepCode & "*" _
               , Operator:=xlAnd
            'copy the visible cells
            .Cells(1, nRowDataLabels).Select
            'see how many rows are in the filtered data
            nRowsFilteredData = .Cells(.Rows.Count, 1).End(-4162).Row - nRowDataLabels 'xlUp=-4162
            
            'if there is no data, then go to the next rep
            If Not nRowsFilteredData > 1 Then
               GoTo NextRepToEmail
            End If
            'select the cells and copy
            Range(.Cells(nRowDataHeader, 1), .Cells(nRowData2, nNumColsData)).Select
            Selection.Copy
         End With 'wsData
            
         'Add  workbook
         Set wbTarget = Workbooks.Add
         Set wsTarget = ActiveSheet
         
         'copy values to Target Sheet
         With wsTarget
            .Paste
            'best-fit columns   ---------------------- this may not work right becaue of heading rows above
            Range(.Cells(1, 1), .Cells(1, nNumColsData)).EntireColumn.AutoFit
            
            'format headings
            With Range(.Cells(nRowDataLabels, 1), .Cells(nRowDataLabels, nNumColsData))
               .Interior.Color = RGB(255, 255, 153)
               .HorizontalAlignment = xlCenter
            End With
            'freeze panes
            .Cells(nRowDataLabels, 1).Select
            ActiveWindow.FreezePanes = True
            
         End With
         'save and close workbook
         wbTarget.Close True, sPathFile
         
         'email workbook ------------------------ customize message
         sMsg = "Hello, " _
            & vbCrLf & vbCrLf & "Daily Open Orders Report is attached for " & sRepCode _
               & " as of " & Date

         Call emailCDOAttachment(sEmail, sPathFile, sMsg, sFilename)
         
         iCountSent = iCountSent + 1
                                 
      End If 'has an email address
      
NextRepToEmail:
      
   Next nRow
   
   With wsData
      .Select
      'select 1st cell in data labels
      .Cells(nRowDataLabels, 1).Select
      'clear filters
      On Error Resume Next
      .ShowAllData
      On Error GoTo Proc_Err
   End With

   MsgBox "Done emailing " & iCountSent & " workbooks", , "Done"
   
Proc_Exit:
   On Error Resume Next
   'release object variables
   Set rngToFilter = Nothing
   Set wsTarget = Nothing
   Set wsData = Nothing
   Set wsEmail = Nothing
   Set wbData = Nothing
   Set wbTarget = Nothing
   Exit Sub
  
Proc_Err:
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   SendToDB"

   Resume Proc_Exit
   Resume
End Sub

Open in new window

0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
It seems to work to a degree and then it freezes. It got to the point where it creates the file but then after that it freezes. I don't get any error messages though so I can't pinpoint where in the code it's freezing. But the file does get created correctly and then it freezes. No email gets sent so it doesn't make it that far.
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
comment these lines in your CDO code:

    With Application
        .ScreenUpdating = False
        .EnableEvents = False  'well maybe not this one
    End With

Open in new window

it is obviously in that code ...

does the file look ok?
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
also, did you compile and save before testing?
0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
HA! It works! WOO HOO! It was my email settings. For some reason the exchange settings won't work from the home office. I changed it to my personal email settings and it went like clockwork. So it's a problem outside the code. Not sure why it won't send it via my exchange settings from home but I'll have to look into that tomorrow. Thank you VERY VERY MUCH for all your help! I GREATLY appreciate it and your quick responses! You're amazing! Thank you, thank you, thank you!
0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
AMAZING!!
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
you're welcome.  anyway, I added an error handler to the CDO code ... and also released the object variables

Sub emailCDOAttachment(ByVal psEmail As String _
   , ByVal psPathFile As String _
   , ByVal psMsg As String _
   , ByVal psSubject As String)

   On Error GoTo Proc_Err
 
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'Send the message using the network (SMTP over the network)
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'Basic (clear-text) authentication. 0 Do not authenticate
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Reports@gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False 'Use SSL for the connection (True or False)
        .Update
    End With

    With iMsg
        Set .Configuration = iConf
        .To = psEmail
        .BCC = "lsalvucci@gmail.com"
        .From = """Reports"" <Reports@gmail.com>"
        .Subject = psSubject  '"Daily Open Orders Report - JBT"
        .TextBody = psMsg  '"As Of " & Date
        .AddAttachment psPathFile  '"\\bcar1\bcar-net\IT\Excel Spreadsheets\Daily Open Orders Report - V.xlsx"
        .Send
    End With

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

Proc_Exit:
   On Error Resume Next
   'release object variables 
   set iMsg = Nothing
   Set iConf = Nothing
   Exit function
  
Proc_Err:
   Application.ScreenUpdating = true
   MsgBox Err.Description, , _
        "ERROR " & Err.Number _
        & "   emailCDOAttachment"

   Resume Proc_Exit
   Resume
End Sub

Open in new window

0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
I feel after all of that, I should get up and do a dance ... happy to help, and happy that you are happy ~
0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
Thank you for the additional error trapping code. I really appreciate all your efforts! You definitely don't take the easy road to helping people. I'll get up and do a dance too! If I were there we'd be dancing together. LOL Thank you again. You're the BEST! If I could give you another 500 points I would! See you around EE again sometime...I'm sure I will be posting again.
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
thank you, Lawrence, and you are welcome ~

by the way, in the release code, perhaps iConf should get released first since it is set second ...
0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
Ok, thank you. I switched them around and made the iConf first.
0
crystal (strive4peace) - Microsoft MVP, AccessRemote Training and ProgrammingCommented:
you're welcome, Lawrence ~ enjoy your evening :)
0
Lawrence SalvucciInformation Technology ManagerAuthor Commented:
Thank you, you as well.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.