Need help making VBA code for Excell 2011 (Mac) more concise

Microsoft Excel for mac 2011 - macintosh
July 30, 2012 at 09:01:48
Specs: Macintosh OS 10.6.8
Hello,

I've successfully created this macro to automatically send emails to a list of contacts via vlookup. It send email only if certain criteria are met via IF statements

It also determines which type of email canned text to send based on an IF statement.

The code looks bulky, and I'm sure it can be improved on, even though it is working fine. I just want to avoid possible trouble later by having the simplest code possible that will accomplish the task at hand.

Here is the code:
[code]Private Sub Workbook_Open()

Dim wrksheet As Worksheet
Dim rng As Range
Dim Ash As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String

On Error GoTo cleanup

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

'Set Progress sheet as active sheet
Worksheets("Progress").Activate
Set Ash = ActiveSheet

'Set Contacts sheet as the sheet to filter and set filter range and filter column (column with names)
Set FilterRange = Worksheets("Contacts").Range("A3:B" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A, first column in the FilterRange

If Ash.Range("I35").Value = "" Then
GoTo cleanup
End If

If Ash.Range("I36").Value > Ash.Range("D7").Value Then
GoTo cleanup
End If

If Ash.Range("K35").Value <> "1" Then
GoTo cleanup
End If

If Ash.Range("P36").Value = "Y" Then
GoTo cleanup
End If

If Ash.Range("O36").Value <> "" Then
GoTo Termination
End If

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Worksheets("Contacts").Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'Look for the mail address in the Contacts worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Worksheets("Contacts").Cells(Rnum, 1).Value, _
Worksheets("Contacts").Range("A4:D" & _
Worksheets("Contacts").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress <> "" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Worksheets("Contacts").Cells(Rnum, 1).Value

MailFromMacWithMail _
bodycontent:="The Validation Summary Report for " & Ash.Range("C1") & " has been approved. Please proceed with Implementation. The projected Launch Date is " & Ash.Range("D6") & ". " & "Applicable CPT Codes are: " & Worksheets("Contacts").Range("E2") & ". " & "Is this a TC test: " & Worksheets("Contacts").Range("F2") & ". ", _
mailsubject:=Ash.Range("C1") & " Validation Breaking News!", _
toaddress:=mailAddress, _
ccaddress:="", bccaddress:="", _
attachment:="", _
displaymail:=False
With Ash
.Range("P36").Value = "Y"
.Range("K36").Value = "1"
End With
End If
'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If
GoTo cleanup

Termination:

If Ash.Range("P36").Value = "Y" Then
GoTo cleanup
End If

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Worksheets("Contacts").Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'Look for the mail address in the Contacts worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Worksheets("Contacts").Cells(Rnum, 1).Value, _
Worksheets("Contacts").Range("A4:D" & _
Worksheets("Contacts").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress <> "" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Worksheets("Contacts").Cells(Rnum, 1).Value
MailFromMacWithMail _
bodycontent:="This Validation Project is terminated. The " & Ash.Range("C1") & " test will not be validated at this time. For further details, refer to the summary report and associated data. Please close out and file all materials and paperwork.", _
mailsubject:=Ash.Range("C1") & " Validation Breaking News!", _
toaddress:=mailAddress, _
ccaddress:="", bccaddress:="", _
attachment:="", _
displaymail:=False
With Ash
.Range("P36").Value = "Y"
.Range("K36").Value = "1"
End With
End If
'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Application.DisplayAlerts = True

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

'Set all Worksheets to be protected upon opening the workbook.
For Each wrksheet In ActiveWorkbook.Worksheets
wrksheet.Protect DrawingObjects:=True, contents:=True, AllowFiltering:=True, UserInterfaceOnly:=True
wrksheet.EnableOutlining = True
Next wrksheet

Worksheets("Contacts").Unprotect
Worksheets("Instructions - Read First").Activate

End Sub[/code]

Thank you for your assistance! I've learned a lot from books, but I am stumped here. Can I use With commands to condense the multiple IF statements?


See More: Need help making VBA code for Excell 2011 (Mac) more concise

Report •


#1
July 30, 2012 at 09:08:43
Please click on the following line, read the instructions on how to post code in this forum, and then repost your code so that it will be easier to read. Thanks!

Click Here Before Posting Data or VBA Code ---> How To Post Data or Code.


Report •

#2
July 30, 2012 at 13:46:26
I apologize for the unreadable code in the initial post.

Private Sub Workbook_Open()

Dim wrksheet As Worksheet
Dim rng As Range
Dim Ash As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String

On Error GoTo cleanup

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

'Set Progress sheet as active sheet
Worksheets("Progress").Activate
Set Ash = ActiveSheet

'Set Contacts sheet as the sheet to filter and set filter range and filter column (column with names)
Set FilterRange = Worksheets("Contacts").Range("A3:B" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A, first column in the FilterRange

If Ash.Range("I35").Value = "" Then
GoTo cleanup
End If

If Ash.Range("I36").Value > Ash.Range("D7").Value Then
GoTo cleanup
End If

If Ash.Range("K35").Value <> "1" Then
GoTo cleanup
End If

If Ash.Range("P36").Value = "Y" Then
GoTo cleanup
End If

If Ash.Range("O36").Value <> "" Then
GoTo Termination
End If

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Worksheets("Contacts").Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'Look for the mail address in the Contacts worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Worksheets("Contacts").Cells(Rnum, 1).Value, _
Worksheets("Contacts").Range("A4:D" & _
Worksheets("Contacts").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress <> "" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Worksheets("Contacts").Cells(Rnum, 1).Value

MailFromMacWithMail _
bodycontent:="The Validation Summary Report for " & Ash.Range("C1") & " has been approved. Please proceed with Implementation. The projected Launch Date is " & Ash.Range("D6") & ". " & "Applicable CPT Codes are: " & Worksheets("Contacts").Range("E2") & ". " & "Is this a TC test: " & Worksheets("Contacts").Range("F2") & ". ", _
mailsubject:=Ash.Range("C1") & " Validation Breaking News!", _
toaddress:=mailAddress, _
ccaddress:="", bccaddress:="", _
attachment:="", _
displaymail:=False
With Ash
.Range("P36").Value = "Y"
.Range("K36").Value = "1"
End With
End If
'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If
GoTo cleanup

Termination:

If Ash.Range("P36").Value = "Y" Then
GoTo cleanup
End If

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Worksheets("Contacts").Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'Look for the mail address in the Contacts worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Worksheets("Contacts").Cells(Rnum, 1).Value, _
Worksheets("Contacts").Range("A4:D" & _
Worksheets("Contacts").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress <> "" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Worksheets("Contacts").Cells(Rnum, 1).Value
MailFromMacWithMail _
bodycontent:="This Validation Project is terminated. The " & Ash.Range("C1") & " test will not be validated at this time. For further details, refer to the summary report and associated data. Please close out and file all materials and paperwork.", _
mailsubject:=Ash.Range("C1") & " Validation Breaking News!", _
toaddress:=mailAddress, _
ccaddress:="", bccaddress:="", _
attachment:="", _
displaymail:=False
With Ash
.Range("P36").Value = "Y"
.Range("K36").Value = "1"
End With
End If
'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Application.DisplayAlerts = True

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

'Set all Worksheets to be protected upon opening the workbook.
For Each wrksheet In ActiveWorkbook.Worksheets
wrksheet.Protect DrawingObjects:=True, contents:=True, AllowFiltering:=True, UserInterfaceOnly:=True
wrksheet.EnableOutlining = True
Next wrksheet

Worksheets("Contacts").Unprotect
Worksheets("Instructions - Read First").Activate

End Sub

Thanks again for your input. The multiple lines of If statements seem clunky to me, and if its possible to split this up into smaller subroutines that get called from the main routine (private sub workbook open()), I would love some feedback on how best to do that.


Report •

Related Solutions


Ask Question