Create Emails from Excel Loop - excel

I have this sample sheet:
My code currently goes through and creates emails based on the name in column H. So Approver1 gets one email for all his people. I have gotten it to de-dupe any repeats of their employee names. Example: Approver 1 gets an email that says 'please approve time for all of your employees below:' and then there is a list of names...Sample1, Sample2, and Sample3. The sheet will often have dupe employees for each approver, as shown in my sheet above.
The code works well for the first set of dupe names (there could be up to 10 of the same Approvers in a row, all getting one email), then runs fine through any singles.
When it hits the next set of repeated approvers it skips the first row in that group, then creates emails for every other division; so it skips a row until it gets to the end of the dupe approver section. So from the sheet, approver1 would get his email all set, then approver2 would get hers, but then approver3 becomes a mess.
How do I get this to loop correctly through an entire list, creating one email for each approver, with all the corresponding names of their people listed only once?
Sub DivisionApprovals()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strdir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strbody2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.rows.count
Set OutMail = OutApp.CreateItem(0)
Set strName = rng.Cells(r, 1)
Set strName3 = rng.Cells(r, 3)
strName2 = Trim(Split(strName, ",")(1))
strBody = "<Font Face=calibri>Dear " & strName2 & ", <br><br> Please approve the following divisions:<br><br>"
With OutMail
.To = rng.Cells(r, 2).Value
.Subject = "Please Approve Divisions"
List = strName3 & "<br>"
Do While rng.Cells(r, 1).Value = rng.Cells(r + 1, 1)
r = r + 1
Set strDept = rng.Cells(r, 3)
.Subject = "Approvals Needed!"
List = .HTMLBody & strDept & "<br>"
r = r + 1
.HTMLBody = List
Loop
.HTMLBody = strBody & "<B>" & List & "</B>" & "<br>" & Signature
.Display
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = Nothing
End Sub

I deleted the previous answer, then un-deleted it in case you need that info. So as to not confuse anyone, the answer building from the OP's code is below.
DISCLAIMER: I am not a fan of the incrementing code style in the Do While, it make sit very difficult to chase errors but I understand the intention. I have included code below this in the way that my brain works and perhaps better coding style, you be the judge.
Alright #learningthisstuff I figured out what was going on, the code assumes the names are sorted. One thing not provided for is if the dept names are the same it will be listed multiple times, are the dept always unique for a person (no dupes?) if there are dupes that is different code.
This code works I just ran it as a macro on a dummy set. Big thing was the sort AND the incrementing logic, I changed a few things to make it more readable/understandable along the way.
I hope this helps you and you can modify as things change for you.
Sub Email_Macro()
'
' Email_Macro Macro
'
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strdir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strbody2 As String
Dim strName3 As Variant
Dim emailWS As Worksheet
Dim nameCol As Double
Dim deptCol As Double
Dim lastRow As Double
Dim startRow As Double
Dim r As Double
Dim depList As String
deptList = ""
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set emailWS = ThisWorkbook.ActiveSheet
startRow = 2 ' starting row
nameCol = 1 'col of name
deptCol = 3 'col of dept
'find the last row with a name in it from the name column
lastRow = emailWS.Cells(emailWS.Rows.Count, nameCol).End(xlUp).Row
'set variable to the starting row #
r = startRow 'this is where the counting begins
'sort the data first before going through the email process
'assumes these are the only columns 1 (nameCol) thru 3 (deptCol) to sort
'assumes you are sorting based on col 1 (nameCol)
emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, deptCol)).Sort key1:=emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, nameCol))
Do While r <= lastRow
Set OutMail = OutApp.CreateItem(0)
Set strName = emailWS.Cells(r, nameCol)
Set strName3 = emailWS.Cells(r, deptCol)
'careful the line below assumes there is always a comma separator in the name
strName2 = Trim(Split(strName, ",")(1))
strBody = "<Font Face=calibri>Dear " & strName2 & ", <br><br> Please approve the following divisions:<br><br>"
With OutMail
.To = emailWS.Cells(r, 2).Value
.Subject = "Please Approve Divisions"
deptList = strName3 & "<br>"
Do While emailWS.Cells(r, 1).Value = emailWS.Cells(r + 1, 1)
r = r + 1
Set strDept = emailWS.Cells(r, 3)
.Subject = "Approvals Needed!"
deptList = deptList & strDept & "<br>"
Loop
.HTMLBody = strBody & "<B>" & deptList & "</B>" & "<br>" & Signature
.Display
End With
Set OutMail = Nothing
'conditionally increment the row based on the name difference
If emailWS.Cells(r, 1).Value <> emailWS.Cells(r + 1, 1) Then
r = r + 1 'increment if there is a new name or no name
deptList = "" 'reset the department list
Else 'Do nothing
End If
Loop
Set OutApp = Nothing
End Sub
Screenshot:
To prove that I don't throw out comments without backing it up with some solution / mentoring? This is much easier for me to understand and troubleshoot. It steps through the rows in a very predictable fashion and we handle each row based on specified conditions. I also try and use variable names that will let you know what they are for.
Sub Email_Macro()
'
' Email_Macro Macro
'
Dim OutApp As Object 'email application
Dim OutMail As Object 'email object
Dim strBody As String 'first line of email body
Dim strName As String 'name in the cell we are processing
Dim strDept As String 'dept of the name we are processing
Dim previousName As String 'previous name processed
Dim nextName As String 'next name to process
Dim emailWS As Worksheet 'the worksheet selected wehn running macro
Dim nameCol As Double 'column # of names
Dim deptCol As Double 'column # of depts
Dim lastRow As Double 'last row of data in column
Dim startRow As Double 'row we wish to start processing on
Dim r As Double 'loop variable for row
'This will be the list of departments, we will build it as we go
Dim depList As String
Dim strSig As String 'email signature
strSig = "Respectfully, <br> Wookie"
deptList = "" 'empty intitialization
previousName = "" 'empty intialization
nextName = "" 'empty intialization
'Turn off screen updating
'Application.ScreenUpdating = False
'choose email application
Set OutApp = CreateObject("Outlook.Application")
'set worksheet to work on as active (selected sheet)
Set emailWS = ThisWorkbook.ActiveSheet
startRow = 2 ' starting row
nameCol = 1 'col of names, can also do nameCol = emailWS.Range("A1").Column
deptCol = 3 'col of depts, can also do deptCol = emailWS.Range("A3").Column
'** Advantage of the optional way is if you have many columns and you don't want to count them
'find the last row with a name in it from the name column
lastRow = emailWS.Cells(emailWS.Rows.Count, nameCol).End(xlUp).Row
'sort the data first before going through the email process using Range sort and a key
'assumes these are the only columns 1 (nameCol) thru 3 (deptCol) to sort
'assumes you are sorting based on col 1 (nameCol)
emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, deptCol)).Sort key1:=emailWS.Range(Cells(startRow, nameCol), Cells(lastRow, nameCol))
'Set up our loop, it will go through every cell in the column we select in the loop
For r = startRow To lastRow
'Get the name and dept
'For the name we will split around the comma and take the second part of array (right of comma)
strName = Trim(Split(emailWS.Cells(r, nameCol), ",")(1))
strDept = emailWS.Cells(r, deptCol)
'if the next name is not blank (EOF)
If emailWS.Cells(r + 1, nameCol) <> "" Then
'assign the next name
nextName = Trim(Split(emailWS.Cells(r + 1, nameCol), ",")(1))
Else
'this is your EOF exit so assume a name
nextName = "Exit"
End If 'Else do noting on this If
If strName <> previousName Then
'Set our "new" name to previousName for looping
'process the "new" name
previousName = strName
'create the email object
Set OutMail = OutApp.CreateItem(0)
'Process as new email
With OutMail
.To = strName 'address email to the name
.Subject = "Please Approve Divisions" 'appropriate subject
deptList = strDept & "<br>" 'add the dept to dept list
'Build the first line of email body in HTML format
strBody = "<Font Face=calibri>Dear " & strName & ", <br><br> Please approve the following divisions:<br><br>"
End With
Else
'The name is the same as the email we opened
'Process Dept only by adding it to string with a line break
deptList = deptList & strDept & "<br>"
End If
'Do we send the email and get ready for another?
If strName <> nextName Then
'the next name is not the same as the one we are processing and we sorted first
'so it is time to send the email
OutMail.HTMLBody = strBody & "<B>" & deptList & "</B>" & "<br><br>" & strSig
OutMail.Display
Else 'Do Nohing
End If
Next r 'move to the next row
'nullify email reference
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
If you want to guard against duplicate departments then I would do it like this, you can see where this goes there is only one end with:
End With
Else
'The name is the same as the email we opened
'Process Dept only by adding it to string with a line break
If InStr(deptList, strDept) = 0 Then
'Dept is not in the list so Add the department
deptList = deptList & strDept & "<br>"
Else
'Do nothing, the dept is already there
End If
End If
I suppose never give up. Everything is possible, maybe just outside of our current skillset (so get some help and keep learning).
Cheers - WWC

If you pivot your data, here is a way to loop through the pivot to get unique information by name.
Pivotted Data
Code
Option Explicit
Sub LoopPivot()
With Sheet1
Dim pt As PivotTable
Set pt = .PivotTables(1)
Dim nameField As PivotField
Set nameField = pt.PivotFields("Name")
Dim nameItem As PivotItem
For Each nameItem In nameField.PivotItems
Dim name As String
name = nameItem.Value
Dim emailField As PivotField
Set emailField = pt.PivotFields("email")
Dim emailItem As PivotItem
Set emailItem = emailField.PivotItems(nameItem.Position)
Dim email As String
email = emailItem.Value
Dim divisionName As Range
Dim division As String
division = vbNullString
For Each divisionName In nameItem.DataRange
division = division & "," & divisionName.Value
Next
division = Mid(division, 2, 255)
Debug.Print name
Debug.Print email
Debug.Print division
Next
End With
End Sub

Here is a little helper stub I use to find a unique list from column A and place that list in column C. Based on a button click. Modify as you wish.
Option Explicit
Private Sub CommandButton1_Click()
Dim thisWS As Worksheet
Dim firstRow As Double
Dim lastRow As Double
Dim workCol As Double
Dim dataRange As Range
Dim uniqueLast As Double
Dim uniqueCol As Double
Dim i As Double
Dim y As Double
Dim Temp As String
Dim found_Bool As Boolean
Set thisWS = ThisWorkbook.Worksheets("Sheet2")
workCol = thisWS.Range("A1").Column
firstRow = 1
uniqueLast = 1
uniqueCol = thisWS.Range("C1").Column
lastRow = thisWS.Cells(thisWS.Rows.Count, workCol).End(xlUp).Row
For i = firstRow To lastRow
Temp = Trim(UCase(thisWS.Range(Cells(i, workCol), Cells(i, workCol))))
Temp = Replace(Temp, "#", "")
found_Bool = False
For y = 1 To uniqueLast
If Temp = thisWS.Range(Cells(y, uniqueCol), Cells(y, uniqueCol)) Then
found_Bool = True
Else ' Do nothing
End If
Next y
If found_Bool = False Then
thisWS.Range(Cells(uniqueLast + 1, uniqueCol), Cells(uniqueLast + 1, uniqueCol)) = Temp
uniqueLast = uniqueLast + 1
Else
End If
Next i
End Sub
Once you do this you can lookup each name in the non unique column and get the appropriate dept for subject or other info.
What you want is really a pivot in VBA (name & dept(s), you could just vba the pivot, that is a little trickier but very doable.
'***************************************************
OK take what Scott has and its very workable. With regard to the pivot table itself a few "helpers". Again, either name the table and just update the range or delete it and make it each time. Do to the project I delete it every time here and keep using the same space to make picot after picot, every time the workbook is opened this scratch space is clear.
This is me creating a pivot of sales data, bear with me, I actually copy the pivot data afterwards to values and then add columns to perform calculations, then I move that to a report, deleting the pivot and working table, basically this all happens away from what the user gets to see when they click a button:
'***************************
'Add Sales Pivot Table
'Last DR is the last data row, you can see it done several times, in the code below, once you do it you will always do it
'CalcSheet is the name of the worksheet in the workbook I am working on
'The range here is defined in Range Format, you could use a named range or use .Range(Cells(row,col),Cells(row,col)) there are several ways
'I name the pivot table upon creation so I can manipulate it better
'I specify the target cell, upper left with which to begin the pivot table
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
CalcSheet.Range("K14:AY" & LastDR), Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:=CalcSheet.Range("CA37"), TableName:="SalesPVT", DefaultVersion _
:=xlPivotTableVersion15
I set the pivot up in the format that I want and then I sort it based on one of the fields:
With CalcSheet.PivotTables("SalesPVT").PivotFields("Salesperson")
.Orientation = xlRowField
.Position = 1
End With
With CalcSheet.PivotTables("SalesPVT").PivotFields("Customer")
.Orientation = xlRowField
.Position = 2
End With
With CalcSheet.PivotTables("SalesPVT").PivotFields("DD Rev")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "$#,##0"
End With
With CalcSheet.PivotTables("SalesPVT").PivotFields("Job Days")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
End With
CalcSheet.PivotTables("SalesPVT").PivotFields("Salesperson").AutoSort _
xlDescending, "Sum of DD Rev"
Perhaps there is another way but now I do not know the dimensions of the pivot table (rows) do I? So I define them here based on the first column where I placed the pivot table and the anchor range I specified in creation:
'Find the last row of Pivot table Data
Dim LastPVTrow As Double
Dim FirstPVTrow As Double
Dim NumPVTrows As Double
Dim PivCol As Double
PivCol = CalcSheet.Range("CB37").Column
FirstPVTrow = CalcSheet.Range("CB37").Row
LastPVTrow = CalcSheet.Cells(Rows.Count, PivCol).End(xlUp).Row
NumPVTrows = LastPVTrow - FirstPVTrow
Here I make a column somewhere else based on the pivot data, your email could occur about right here if you wanted:
'make the Avg Rev/Job Day Column
For i = 1 To NumPVTrows ' four columns in this table
CalcSheet.Range("CD" & (100 + i)).NumberFormat = "$#,##0"
If CalcSheet.Range("CC" & (FirstPVTrow + i)) <> 0 Then
CalcSheet.Range("CD" & (100 + i)) = CalcSheet.Range("CB" & (FirstPVTrow + i)) / CalcSheet.Range("CC" & (FirstPVTrow + i))
Else
CalcSheet.Range("CD" & (100 + i)) = 0
End If
Next i
'Here I am going to leave a bunch of stuff out but it puts headers on my table that is only missing the pivot and adds some more columns and calculations, counts the values based on specified ranges etc and finds averages
'Then I copy the pivot table and delete it, happens every time a button is clicked and a new workbook is selected to process
'copy pivot table to get rid of it
CalcSheet.PivotTables("SalesPVT").TableRange1.Copy
'Paste it as values with formatting
CalcSheet.Range("CA100").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Delete Sales Pivot from the file
CalcSheet.PivotTables("SalesPVT").TableRange1.Delete
'Clear Work Space
CalcSheet.Range("CA1:CN500").Clear
Once I have processed the sales persons, I do it again by customer in the same working scratch space, build a table make new columns and headers down below based on the data, copy the table as values and then after putting it into a report, delete it all, for the next go around. I format my little table before export: bolding the headers, putting grey on the sales person or the customer, the totals line is blue, I right align the numbers in the cell, there sis alot of code left out to focus on the pivot.
So here is similar pivot code building the table for customers
'***************************************
'Make the Customer Pivot and table
'***************************************
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
CalcSheet.Range("K14:AY" & LastDR), Version:=xlPivotTableVersion15).CreatePivotTable _
TableDestination:=CalcSheet.Range("CA37"), TableName:="CustPVT", DefaultVersion _
:=xlPivotTableVersion15
With CalcSheet.PivotTables("CustPVT").PivotFields("Customer")
.Orientation = xlRowField
.Position = 1
End With
With CalcSheet.PivotTables("CustPVT").PivotFields("DD Rev")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "$#,##0"
End With
With CalcSheet.PivotTables("CustPVT").PivotFields("Job Days")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
End With
'Find the last row of Pivot table Data
FirstPVTrow = CalcSheet.Range("CA37").Row
LastPVTrow = CalcSheet.Cells(Rows.Count, PivCol).End(xlUp).Row
'LastPVTrow = CalcSheet.Range("CB37:CB500").Find((0), LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
NumPVTrows = LastPVTrow - FirstPVTrow
etc. etc. etc . . .
I am sure the users on here are a lot more elegant.
I strive for code that is readable and usually understandable by me (hopefully others) and limited by my skillset, you have to come back to this stuff months or years later, trust me it looks different than when you are "living in the moment of creation" Take the time to leave yourself bread crumbs, name your variables and your tables so they make sense. Try an use named ranges rather than "hard coding" ranges, I know I did it here, do as I say . . . not as I do. I will usually only do this in areas that will later be erased and wiped. No excuses but I was moving in a rush on this one.
Cheers

I'm using a different technic to solve the same problem with Excel. First of all I have a Function to open a new ADODB-Recordset:
Function RST_Excel(strExceldatei As String, strArbeitsblatt As String, strWHERE As String, Optional strBereich As String, _
Optional strDatenfelder As String = "*") As ADODB.Recordset
Dim i As Integer
Dim rst As ADODB.Recordset
Dim strConnection As String
Dim strSQL As String
On Error GoTo sprFehler
strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & strExceldatei
If global_con Is Nothing Then
Set global_con = New ADODB.Connection
With global_con
.Open strConnection
End With
End If
strSQL = "SELECT " & strDatenfelder & " FROM [" & strArbeitsblatt & "$" & strBereich & "] WHERE " & strWHERE
Set rst = New ADODB.Recordset
With rst
.Source = strSQL
.CursorLocation = adUseClient
.ActiveConnection = global_con
.Open
Set RST_Excel = rst
End With
sprEnde:
Set rst = Nothing
Exit Function
sprFehler:
Set rst = Nothing
Set RST_Excel = Nothing
End Function
Then I open the ADODB-Recordset from another Routine:
Dim strWHERE As String
Dim strFields As String
Dim rst_Recipients As ADODB.Recordset
strWHERE = "Surname IS NOT NULL AND Emailadress IS NOT NULL"
strFields = "Surname, Name, Emailadress, SMIME"
Set rst_Empfänger = RST_Excel(ThisWorkbook.FullName, "Email", strWHERE, "A1:M1000", strFields)
As the query is passed as an SQL-Statement you could also pass an Statement to get unique results.
The advance for me is that I could easily move through the Recordset:
With rst
.movefirst
do until .eof
debug.print .fields("surename").value
.movenext
loop
end with

I think you can use this to do what you want to do.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Related

Pull Data By Vendor from Excel for Outlook Email

I have a list of vendors that I sort by name and then have a macro go through and pull out data pieces from fields and place them inside an Outlook email. Pretty straightforward until I get to vendors with multiple lines, as I then need to have the code know to look at all the lines for that vendor and pull their info and place it into a list in the email (so they do not get multiple emails all at once).
The above image is a sample of the list after I have sorted it by vendor. So I would want one email for each vendor, but vendor1 would need the data from Invoice, Paid Amt, Check ID, and Check Dt for both of his lines. Vendor 2 would just have one line, and Vendor3 would have 3. I need a way to have the macro know to look at the vendor name (or Vendor #) and know that it needs to pull the data from the next line and include it in that same email until it is at the next vendor.
I am not a programmer and am trying to make this work. Below is an example of what I have been trying so far but it only creates one email for every line. Hoping someone smarter than me can help me. Thanks.
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strbody As String
Dim strname As String
Dim strName1 As String
Dim strDept As String
Dim strName2 As String
Dim lr As Long
Dim oItem As Object
Dim dteSat As Date
Dim nextSat As Date
Dim lastRow As Long
Dim ws As String
'Link to Outlook, use GetBoiler function to pull email signature
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Uncashed Checks.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
'Define the date for the next Saturday
With Item
K = Weekday(TODAY)
dteChk = Weekday(TODAY) - 30
dteSat = Now() + (10 - K)
nextSat = Date + 7 - Weekday(Date, vfSaturday)
End With
'Select the currently active sheet and insert a column next to column I, then fill it with the word 'yes'. The yes values will act as triggers to tell the code to run for that row.
'Delete first 7 rows of report. Find the Paid Amt header and then replace that column with a re-formatted one that shows the full numbers with decimals and zeroes. Change column E
'to UPPER case using the index and upper functions.
lr = ActiveSheet.UsedRange.Rows.Count
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Rows("1:7").Select
Columns("C").SpecialCells(xlBlanks).EntireRow.Delete
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set rng8 = Range("A1:Z1").Find("Paid Amt")
Set rng9 = ActiveSheet.Range(rng8, ActiveSheet.Cells(Rows.Count, rng8.Column).End(xlUp).Address)
rng9.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "=TEXT(RC[+1],""#.00"")"
ActiveCell.Copy
Range(ActiveCell.Offset(350 - ActiveCell.Row, 0), ActiveCell.Offset(1, 0)).Select
ActiveSheet.Paste
ActiveCell.Offset.Resize(1).EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset.Resize(1).EntireColumn.Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToRight
Range("i2") = "Yes"
Range("I2").AutoFill Destination:=Range("I2:I" & lr)
[e2:e350] = [INDEX(UPPER(e2:e350),)]
'Begin a loop that looks at all the yes values in column I and then begins to create emails. Define the columns to be used for data by looking for the header names such as Paid Amt.
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "I").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
Set rng8 = Range("A1:Z1").Find("Paid Amt")
Set foundCell = Cells(cell.Row, rng8.Column)
Set rng9 = Range("A1:AG1").Find("Check Dt")
Set foundCell1 = Cells(cell.Row, rng9.Column)
Set rng12 = Range("A1:AG1").Find("Student Perm Address")
Set foundcell2 = Cells(cell.Row, rng12.Column)
'Create the actual email data, definiing the body and recipients/names, etc, based on the values in the cells noted below. Sentonbehalf is the 'From' field. Change font color
'using the hexadecimal codes. The one used here 1F497D is Blue-Gray.
With OutMail
strname = Cells(cell.Row, "A").Value
strName2 = Trim(Split(strname, ",")(1))
strName3 = Cells(cell.Row, "R").Value
strName4 = Cells(cell.Row, "E").Value
strbody = "<Font face = TimesNewRoman p style=font-size:18.5px color = #0033CC)<br><br>You are receiving this email because you have an uncashed check that was sent to you over 30 days ago. " & _
"Please cash or deposit your check.<br><br>" & _
"<B>The amount of the check is $" & foundCell & " and is dated " & foundCell1 & ". The check was mailed to the following address: <br><br>" & _
"<ul>" & foundcell2 & "<br></B></ul>"
.SentOnBehalfOfName = "accounts-payable#salemstate.edu"
.To = cell.Value
.Subject = "Uncashed Check from Salem State University"
.HTMLBody = "<Font face = TimesNewRoman p style=font-size:26.5px color = #0033CC><B>" & "Important Information Regarding Your Student Account </B><br><br><p style=font-size:18.5px> Dear " & strName2 & ", " & strbody & "<br>" & signature & "<HTML><BODY><IMG src='C:\Users\gmorris\Pictures\Saved Pictures\220px-Salem_State_University_logo.png' /></BODY></HTML>"
.display 'Or use Send
End With
Set OutMail = Nothing
End If
Next cell
End Sub
If the email addresses are sorted:
When the email address matches the previous:
Bypass creating email, append to the body.
When there is a new email address:
Send the existing mail before creating new email.
Option Explicit
Sub oneEmail_SortedEmailAddresses()
Dim OutApp As Object
Dim OutMail As Object
Dim strVoucher As String
Dim lr As Long
Set OutApp = CreateObject("Outlook.Application")
lr = ActiveSheet.UsedRange.Rows.Count
Dim toAddress As String
Dim i As Long
Dim refundDescYes As Boolean
For i = 2 To lr
' Email address
If ActiveSheet.Range("N" & i).Value <> "" Then
' One email per email address
' This assumes the addresses are sorted
If ActiveSheet.Range("N" & i).Value <> toAddress Then
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
toAddress = ActiveSheet.Range("N" & i).Value
Debug.Print toAddress
Set OutMail = Nothing
refundDescYes = False
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddress
.Subject = "Uncashed Check from Salem State University"
End With
End If
' Refund Desc
If ActiveSheet.Range("I" & i).Value = "Yes" Then
refundDescYes = True
' Voucher
strVoucher = Cells(i, "D").Value
With OutMail
.HTMLBody = .HTMLBody & "<br>" & strVoucher & "<br>"
End With
End If
End If
Next
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
Set OutMail = Nothing
Debug.Print "Done."
End Sub

Impossible Excel-VBA Email Loop

If someone could help me from going insane, my mother would appreciate it.
I have a long list of email addresses (many repeats) with associated Audit Locations. Basically I need to create one email for each email address and populate said email body with a list of all the associated Audit Locations.
e.g.
Column One (Email Address) | Column 2 (Audit Location)
Yoda1#lightside.org | Coruscant
Yoda1#lightside.org | Death Star
Yoda1#lightside.org | Tatooine
Vader#Darkside.org | Death Star
Vader#Darkside.org | Coruscant
Jarjar#terrible.org | Yavin
So far I have created a CommandButton Controlled vba that takes Column One and makes it unique in a new worksheet.
Then I have another sub that creates an email for each unique email address. But I am stuck on the "If...Then" statement. Essentially, I want to add the information in Column 2 (Audit Location) if the Recipient of the email is the email address in Column One and then continue to append to the email body until the email address no longer equals the recipient email address. Any guidance would be huge.
Private Sub CommandButton1_Click()
Call MakeUnique
Call EmailOut
End Sub
Sub MakeUnique()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
'Put the data in an array
vaData = Sheet1.Range("A:A").Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheets.Add.Name = "Unique"
ActiveSheet.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
Sub EmailOut()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Dim cell As Range
For Each cell In Worksheets("Unique").Columns("a").Cells.SpecialCells(xlCellTypeConstants)
recip = cell.Value
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
For Each org In Columns("b").Cells.SpecialCells(xlCellTypeConstants)
If org.Value Like recip Then
xMailBody = "Body content" & vbNewLine & vbNewLine & _
"This is line 1" & " " & cell.Offset(0, 3).Value & vbNewLine & _
[B5] & vbNewLine & _
"This is line 2"
End If
Next org
On Error Resume Next
With xOutMail
.To = recip
.CC = ""
.BCC = ""
.Subject = cell.Offset(0, 2).Value & " " & cell.Offset(0, 3).Value & " " & "Remittance Advice"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
Next
End Sub
Based on your example I quickly wrote the following:
Option Explicit
Public Sub SendEmails()
Dim dictEmailData As Object
Dim CurrentWorkBook As Workbook
Dim WrkSht As Worksheet
Dim rngToLookUp As Range
Dim lngLastRow As Long, i As Long
Dim arryEmailData As Variant
Dim objOutlookApp As Object, objOutlookEmail As Object
Dim varKey As Variant
Application.ScreenUpdating = False
Set CurrentWorkBook = Workbooks("SomeWBName")
Set WrkSht = CurrentWorkBook.Worksheets("SomeWSName")
lngLastRow = WrkSht.Cells(WrkSht.Rows.Count, "A").End(xlUp).Row 'Find last row with data
Set rngToLookUp = WrkSht.Range("A2:B" & lngLastRow) 'set range for last row of data
arryEmailData = rngToLookUp.Value2 'Get the email data from the sheet into an array
Set dictEmailData = CreateObject("Scripting.Dictionary") 'set the dicitonary object
On Error GoTo CleanFail
For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
varKey = UCase(Trim(arryEmailData(i, 1)))
If Not dictEmailData.Exists(varKey) Then
dictEmailData(varKey) = vbNewLine & vbNewLine & Trim(arryEmailData(i, 2))
Else
dictEmailData(varKey) = dictEmailData(varKey) & vbNewLine & Trim(arryEmailData(i, 2))
End If
varKey = Empty
Next i
'for each unique key in the dicitonary
'get the corresponding item
'created in the loop above
Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object
Dim Msg As String, MailBody As String
For Each varKey In dictEmailData.Keys
Msg = dictEmailData.Item(varKey)
Set objOutlookEmail = objOutlookApp.CreateItem(0)
MailBody = "Dear Colleague," & Msg
With objOutlookEmail
.To = varKey
.Subject = "Remittance Advice"
.Body = MailBody
.Send
End With
Set objOutlookEmail = Nothing
Msg = Empty: MailBody = Empty
Next
MsgBox "All Emails have been sent", vbInformation
CleanExit:
Set objOutlookApp = Nothing
Application.ScreenUpdating = True
Exit Sub
CleanFail:
Resume CleanExit
End Sub
Add the first occurrence of a varKey = email address to the dictionary dictEmailData along with its corresponding item dictEmailData(varKey) = Email body. On the next occurrence of the email address, append to the Email body. Once the dictionary is built, loop through it and send the emails
Printing to the immediate window yields:

(VBA) Send Mails with multiple attachements, duplicate mail addresses in list

I have an Excel Sheet (let's call it "Sheet2") with let's say 200 Names in column [A] and the attachement for the Name in the column next to it [B].
There is another Sheet ("Sheet1") with the mail addresses for each Name. Important! -> This Sheet1-list is longer than the first list with the 200 Names.
It appears, that there are duplicate entries in the Sheet "Sheet2" (column [A]) but with different attachments.
I would like to only send out one mail with all necessary attachements for a user, somehow I cannot manage to do so...
The loop I got creates mails for every user in the list "Sheet1", but I only need mails for the users in list "Sheet2".
Hope to find an answer here. Thanks!
My code:
Sub Mails()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim FileName As Variant
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Set wksDest = ThisWorkbook.Worksheets("Sheet2")
Set wksSource = ThisWorkbook.Worksheets("Sheet1")
Dim LastRowSource As Long
LastRowSource = wksSource.Cells(wksSource.Rows.Count, "A").End(xlUp).Row
Dim LastRowDest As Long
LastRowDest = wksDest.Cells(wksDest.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowSource
Dim OutApp As Object
Dim OutMail As Object
Dim CC As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim TC_User As String
Dim TC_Attachement As String
Dim TC_File As String
TC_User = ""
CC = ""
TC_User = wksSource.Range("A" & i)
TC_USer_mail = wksSource.Range("B" & i)
TC_Attachement = ""
With OutMail
.To = TC_USer_mail
.BCC = ""
.Importance = 2
.Subject = "for you"
.HTMLBody = "<body style='font-family:arial;font-size:13'>" & _
"<b>############################################<br>" & _
"Diese Mail wurde automatisch erstellt<br>" & _
"############################################</b><br><br>" & _
"Hallo " & TC_User & "," & "<br><br>" & _
"blabla.<br><br>" & _
"</body>"
For g = 2 To LastRowDest
If wksDest.Range("A" & g) = TC_User Then
TC_File = wksDest.Range("B" & g)
TC_Attachement = "C:\Users\bla\Documents" & "\" & TC_File
If Dir(TC_Attachement) <> "" Then
.Attachments.Add TC_Attachement
'GoTo nextvar
Else
End If
End If
'nextvar:
Next g
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Ende:
End Sub
Ok, I found my solution. Maybe it's not that elegant, but it works.
I wrote this code right before the "With OutMail" - Statement.
This will check whether the User-ID from the mail database is actually in the list with the receipients, if not this User-ID will be skiped.
For j = 2 To LastRowSource
If TC_User = wksDest.Range("A" & j) Then
GoTo weiter_j
End If
Next j
GoTo Ende:
weiter_j:
So there are a unknown number of attachments for each name (ie., not necessarily one) and you need them grouped together? (and it sounds like a one-time thing?)
Just copy and paste one table below the other so that the name columns lines up, and then simply go Sort the list (Data → Sort) and then the names will be grouped together.
From here there are a few ways you could arrange the list to automate the sending process. By the sounds of it, most of the names have one attachment, so send those like you were going to, and send the additional ones manually.
Handling a one-off task manually can often be quicker and easier than trying to automate it.
If this is going to be a recurring task, then try to find a better way to organize the source data (like a simple Access table.)

Pull Only One Unique Item from Column of Dupes Based on Another Cell

I have a sheet that looks like this:
I have VBA code that launches an email and takes data from the sheet and puts it in the email body based on an inputbox value that is searched for in the sheet. Values are grabbed from the row based on finding that value. What I am having trouble with now is we have many dupes and I want to pull a name only once, and then getting it to loop, creating a new email when it hits a new approver name, then grabbing all of that approver's customers, and so on.
Example from above sheet:
Email says 'Dear Chris,
Your customers Thomas, Mark, and Jared all need to be reviewed."
So I need code that gets all customers (column C) assigned to one approver (column E), but only grabs one instance of each customer name.
Then, it creates a new separate email when it finds the next approver, in this case John. So the approver name becomes a delimiter.
I am unsure how to do this, or what is even the best approach. Can anyone offer up any ideas? I am learning, but this part is giving me trouble.
Here is the code I have so far:
Sub Test()
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim x As Long
Dim r As Long
Dim lr, lookRng As Range
Dim findStr As String
Dim foundCell As Variant
Dim foundcell1 As Variant
Dim foundcell2 As Variant
Dim strbody As String
Dim sigstring As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'Input box(es)
findStr = InputBox("Enter approver name to find")
'Greeting based on time of day
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
'Search for input box values and set fields to be pulled
lr = Cells(Rows.Count, "c").End(xlUp).Row
Set lookRng = Range("d1:d" & lr)
valuefound = False
For x = 1 To lr
If Range("c" & x).Value = findStr Then
Set foundCell = Range("B" & x).Offset(0, 4)
Set foundcell1 = Range("e" & x).Offset(0, 1)
Set foundcell2 = Range("B" & x).Offset(0, 5)
valuefound = True
End If
Next x
'Ends the macro if input values to not match the sheet exactly
If Not valuefound Then
MsgBox "Is case-sensitive, Must be exact name", vbExclamation, "No
Match!"
Exit Sub
End If
The way I would approach this is to query your table using SQL to exclude any duplicates (I adapted this example), then iterate over the returned recordset using a dictionary to store your approvers and their customers.
To get the below example to work I've added the Microsoft ActiveX Data Objects 6.1 Library (for the SQL), and the Microsoft Scripting Runtime (for the dictionary), I believe it does what you need:
Sub GetApproversAndCustomers()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
'only retrieve unique combinations of approvers and customers
strSQL = "SELECT DISTINCT [Approver Name],[Customer Name] FROM [Sheet1$B1:E11]"
rs.Open strSQL, cn
Dim approvers As Dictionary
Set approvers = New Dictionary
Do Until rs.EOF
'only add the approver to the collection if they do not already exist
If approvers.Exists(rs.Fields("Approver Name").Value) = False Then
'if they dont exist, add both the approver and customer to the dictionary
approvers.Add rs.Fields("Approver Name").Value, rs.Fields("Customer Name").Value
Else
'if they do exist, find the approver and add the customer to the existing list
approvers.Item(rs.Fields("Approver Name").Value) = approvers.Item(rs.Fields("Approver Name").Value) & ", " & rs.Fields("Customer Name").Value
End If
rs.MoveNext
Loop
'iterate over the dictionary, outputting our values
Dim strKey As Variant
For Each strKey In approvers.Keys()
Debug.Print "Dear " & strKey & ", Your customer(s) " & approvers(strKey) & " all need to be reviewed."
Next
End Sub
Here's a version that doesn't use SQL, I hope it works better than the previous one!
It loops over the table until there are no more rows with data in. It creates a dictionary of approvers and adds the corresponding customer (using the offset method) unless that customer has already been added.
Option Explicit
Public Function GetApproversAndCustomers2(ByVal approversColumn As String, ByVal customerNameColumn As String)
Dim approvers As Object
Set approvers = CreateObject("Scripting.Dictionary")
Dim iterator As Integer
iterator = 2
Do While Len(Sheet1.Range(approversColumn & iterator).Value) > 0
Dim approver As String
approver = Sheet1.Range(approversColumn & iterator).Value
If Not approvers.Exists(approver) Then
If Len(approver) > 0 Then
approvers.Add approver, Sheet1.Range(approversColumn & iterator).Offset(0, -2)
End If
Else
If InStr(1, approvers.Item(approver), Sheet1.Range(approversColumn & iterator).Offset(0, -2).Value) = 0 Then
approvers.Item(approver) = approvers.Item(approver) & ", " & Sheet1.Range(approversColumn & iterator).Offset(0, -2).Value
End If
End If
iterator = iterator + 1
Loop
iterator = 2
Dim key As Variant
For Each key In approvers.Keys
Debug.Print "Dear " & key & ", Your customer(s) " & approvers(key) & " all need to be reviewed."
Next
End Function

Excel do not print if zero

my actual code is :
Option Explicit
Sub SaveMailActiveSheetAsPDFIn2016()
'Ron de Bruin : 1-May-2016
'Test macro to save/mail the Activesheet as pdf with ExportAsFixedFormat with Mail
Dim FileName As String
Dim FolderName As String
Dim Folderstring As String
Dim FilePathName As String
Dim strbody As String
'Check for AppleScriptTask script file that we must use to create the mail
If CheckAppleScriptTaskExcelScriptFile(ScriptFileName:="RDBMacMail.scpt") = False Then
MsgBox "Sorry the RDBMacMail.scpt is not in the correct location"
Exit Sub
End If
'My example sheet is landscape, I must attach this line
'for making the PDF also landscape, seems to default to
'xlPortait the first time you run the code
ActiveSheet.PageSetup.Orientation = xlLandscape
'Name of the folder in the Office folder
FolderName = "TempPDFFolder"
'Name of the pdf file
FileName = "Order " & [C1] & " " & Format(Date, "dd-mm-yyyy") & ".pdf"
Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
FilePathName = Folderstring & Application.PathSeparator & FileName
'Create the body text in the strbody string
strbody = "Hi " & [C2] & "," & vbNewLine & vbNewLine & _
"Please find attached our new order" & vbNewLine & _
vbNewLine & _
"Thanks"
'expression A variable that represents a Workbook, Sheet, Chart, or Range object.
'Not working if you change activeworkbook, always save the activesheet
'Also the parameters are not working like in Windows
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
FilePathName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
'Call the MacExcel2016WithMacMailPDF function to save the new pdf and create the mail
'When you use more mail addresses separate them with a ,
'Look in Mail>Preferences for the name of the mail account or signature
'Account name looks like this : "Your Name <your#mailaddress.com>"
MacExcel2016WithMacMailPDF subject:=[C6] & Format(Date, "dd/mm/yy"), _
mailbody:=strbody, _
toaddress:=[C3], _
ccaddress:=[C4], _
bccaddress:=[C5], _
attachment:=FilePathName, _
displaymail:=True, _
thesignature:="", _
thesender:=""
End Sub
I would like that all cells from E column in the print area =0 not to be displayed and that the sheet shrinks itself (like deleting the lines were =0), this before creating the .pdf document and opening mailbox.
I dunno if I'm clear enough sorry
Thank you for your help though
Assuming column E of Sheet1 is the one you want to hide if filled with zeros:
Sub hideZeroFilledColumn()
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("E:E")
rng.EntireColumn.Hidden = (Excel.WorksheetFunction.Count(rng) = _
Excel.WorksheetFunction.CountIf(rng, "0"))
End Sub
Or, if you want to hide just the lines when cell value in column E:E is 0:
Sub hideLineWithZero()
Dim WS As Worksheet
Set WS = ThisWorkbook.Worksheets("Sheet1")
Dim strColumn As String
strColumn = "E" 'If the column you want to check is "E:E"
'Getting first row of printarea and setting "rngPrintStart" to that row in column strColumn
Dim rngPrintStart As Range
'The split is used to separate the start and end of the PrintArea address
'Here we take component "0" of the split, so the start part of the PrintArea
Set rngPrintStart = Range(Split(WS.PageSetup.PrintArea, ":")(0))
Set rngPrintStart = WS.Range(strColumn & rngPrintStart.Row)
'Getting last row of printarea and setting "rngPrintEnd" to that row in column strColumn
Dim rngPrintEnd As Range
'The split is used to seperate the start and end of the PrintArea address
'Here we take component "1" of the split, so the end part of the PrintArea
Set rngPrintEnd = Range(Split(WS.PageSetup.PrintArea, ":")(1))
Set rngPrintEnd = WS.Range(strColumn & rngPrintEnd.Row)
'Merging rngPrintStart and rngPrintEnd ranges from printarea in column strColumn
Dim rngPrintColumnE As Range
Set rngPrintColumnE = WS.Range(rngPrintStart, rngPrintEnd)
Dim rng As Range
Dim rngToHide As Range
'looking in all cells from rngPrintColumnE
For Each rng In rngPrintColumnE
'checking if cell value is equal to 0 and is not empty
If (rng.Value2 = 0) And (rng.Value2 <> "") Then
'Building the range to be hidden
If rngToHide Is Nothing Then 'For the first time when "rngToHide" is not yet set
Set rngToHide = rng
Else
Set rngToHide = Union(rngToHide, rng)
End If
End If
Next rng
'to hide the rows from the previously built range
rngToHide.Rows.EntireRow.Hidden = True
End Sub
I'm assuming you want to hide column E if all the values in it are zero?
Do a sum of the values into another cell (X99 in my example) then use the following code:
With ActiveSheet
If .Range("X99").Value = 0 Then
.Range("e:e").EntireColumn.Hidden = True
Else
.Range("e:e").EntireColumn.Hidden = False
End If
End With
Edit:
You can use Abs(Min(E:E))>0 instead of Sum if you have negative values
For some reason I can't add another answer so here goes with another edit.
To hide rows that have zero in the e column:
Dim i As Integer
Dim pa As Range
Dim ecolnumber As Integer
ecolnumber = 5
Set pa = Range(ActiveSheet.PageSetup.PrintArea)
For i = 0 To pa.Rows.Count
Dim ecell As Range
Set ecell = pa(i, ecolnumber)
ecell.EntireRow.Hidden = ecell.Value = 0
Next
Note the ecolnumber, you may have to change it to reference the correct column.
After you have done all your stuff you can unhide the rows with:
For i = 0 To pa.Rows.Count
Set ecell = pa(i, ecolnumber)
ecell.EntireRow.Hidden = False
Next

Resources