• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 271
  • Last Modified:

Use one Excel VBA code instead of 5 similar ones

The codes below send out an email, where the body like all other email fields (subject, To, Cc, etc.) is a named range of an excel sheet. The only difference between the codes is the number of attachments and the name(s) of the ranges.

How can I simplify this in order to just have the core code just once instead of five times? So that the Banana code would just call this subroutine or core code and apply that the "Banana" range values/names and # of attachments be used?

Hope I am comprehensible  :o)
Sub BananaSend()
   
   'Application.ScreenUpdating = False
   'Application.DisplayAlerts = False
   
   Sheets("mailer").Select
   Range("BananaBody").Select
   
   Dim MailToAddress As String
    MailToAddress = Range("BananaTo").Value
   Dim MailCcAddress As String
    MailCcAddress = Range("BananaCc").Value
   Dim MailSubject As String
    MailSubject = Range("BananaSubject").Value
   Dim BananaAttachment1 As String
   Dim BananaAttachment2 As String
   Dim BananaAttachment3 As String
   Dim BananaAttachment4 As String
   Dim BananaAttachment5 As String
   Dim BananaAttachment6 As String
   Dim BananaAttachment7 As String
   Dim BananaAttachment8 As String
   Dim BananaAttachment9 As String
   Dim BananaAttachment10 As String
   Dim BananaAttachment11 As String
   Dim BananaAttachment12 As String
   Dim BananaAttachment13 As String
   
   BananaAttachment1 = Range("Banana1").Value
   BananaAttachment2 = Range("Banana2").Value
   BananaAttachment3 = Range("Banana3").Value
   BananaAttachment4 = Range("Banana4").Value
   BananaAttachment5 = Range("Banana5").Value
   BananaAttachment6 = Range("Banana6").Value
   BananaAttachment7 = Range("Banana7").Value
   BananaAttachment8 = Range("Banana8").Value
   BananaAttachment9 = Range("Banana9").Value
   BananaAttachment10 = Range("Banana10").Value
   BananaAttachment11 = Range("Banana11").Value
   BananaAttachment12 = Range("Banana12").Value
   BananaAttachment13 = Range("Banana13").Value
      
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
'removes existing attachments
For cp = .Item.Attachments.Count To 1 Step -1
.Item.Attachments(cp).Delete
Next cp
      'adds mail items to message
      .Item.To = MailToAddress
      .Item.CC = MailCcAddress
      .Item.Subject = MailSubject
      .Item.Attachments.Add BananaAttachment1
      .Item.Attachments.Add BananaAttachment2
      .Item.Attachments.Add BananaAttachment3
      .Item.Attachments.Add BananaAttachment4
      .Item.Attachments.Add BananaAttachment5
      .Item.Attachments.Add BananaAttachment6
      .Item.Attachments.Add BananaAttachment7
      .Item.Attachments.Add BananaAttachment8
      .Item.Attachments.Add BananaAttachment9
      .Item.Attachments.Add BananaAttachment10
      .Item.Attachments.Add BananaAttachment11
      .Item.Attachments.Add BananaAttachment12
      .Item.Attachments.Add BananaAttachment13
      .Item.Send
   End With
    
    'Application.ScreenUpdating = True
    'Application.DisplayAlerts = True
       Range("Fruit").Select

End Sub


Sub AppleSend()
   
   'Application.ScreenUpdating = False
   'Application.DisplayAlerts = False
   
   Sheets("mailer").Select
   Range("AppleBody").Select
   
   Dim MailToAddress As String
    MailToAddress = Range("AppleTo").Value
   Dim MailCcAddress As String
    MailCcAddress = Range("AppleCc").Value
   Dim MailSubject As String
    MailSubject = Range("AppleSubject").Value
   Dim AppleAttachment1 As String
   Dim AppleAttachment2 As String
   Dim AppleAttachment3 As String
   Dim AppleAttachment4 As String
   Dim AppleAttachment5 As String
   Dim AppleAttachment6 As String
   Dim AppleAttachment7 As String
   Dim AppleAttachment8 As String
   Dim AppleAttachment9 As String
   Dim AppleAttachment10 As String
   Dim AppleAttachment11 As String
   Dim AppleAttachment12 As String
   
   AppleAttachment1 = Range("Apple1").Value
   AppleAttachment2 = Range("Apple2").Value
   AppleAttachment3 = Range("Apple3").Value
   AppleAttachment4 = Range("Apple4").Value
   AppleAttachment5 = Range("Apple5").Value
   AppleAttachment6 = Range("Apple6").Value
   AppleAttachment7 = Range("Apple7").Value
   AppleAttachment8 = Range("Apple8").Value
   AppleAttachment9 = Range("Apple9").Value
   AppleAttachment10 = Range("Apple10").Value
   AppleAttachment11 = Range("Apple11").Value
   AppleAttachment12 = Range("Apple12").Value
      
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
'removes existing attachments
For cp = .Item.Attachments.Count To 1 Step -1
.Item.Attachments(cp).Delete
Next cp
      'adds mail items to message
      .Item.To = MailToAddress
      .Item.CC = MailCcAddress
      .Item.Subject = MailSubject
      .Item.Attachments.Add AppleAttachment1
      .Item.Attachments.Add AppleAttachment2
      .Item.Attachments.Add AppleAttachment3
      .Item.Attachments.Add AppleAttachment4
      .Item.Attachments.Add AppleAttachment5
      .Item.Attachments.Add AppleAttachment6
      .Item.Attachments.Add AppleAttachment7
      .Item.Attachments.Add AppleAttachment8
      .Item.Attachments.Add AppleAttachment9
      .Item.Attachments.Add AppleAttachment10
      .Item.Attachments.Add AppleAttachment11
      .Item.Attachments.Add AppleAttachment12
      .Item.Send
   End With
    
    'Application.ScreenUpdating = True
    'Application.DisplayAlerts = True
       Range("Fruit").Select

End Sub

Sub OrangeSend()
   
   'Application.ScreenUpdating = False
   'Application.DisplayAlerts = False
   
   Sheets("mailer").Select
   Range("OrangeBody").Select
   
   Dim MailToAddress As String
    MailToAddress = Range("OrangeTo").Value
   Dim MailCcAddress As String
    MailCcAddress = Range("OrangeCc").Value
   Dim MailSubject As String
    MailSubject = Range("OrangeSubject").Value
   Dim OrangeAttachment1 As String
   Dim OrangeAttachment2 As String
   
   OrangeAttachment1 = Range("Orange1").Value
   OrangeAttachment2 = Range("Orange2").Value
      
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
   
   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
'removes existing attachments
For cp = .Item.Attachments.Count To 1 Step -1
.Item.Attachments(cp).Delete
Next cp
'adds mail items to message
      .Item.To = MailToAddress
      .Item.CC = MailCcAddress
      .Item.Subject = MailSubject
      .Item.Attachments.Add OrangeAttachment1
      .Item.Attachments.Add OrangeAttachment2
      .Item.Send
   End With
    
    'Application.ScreenUpdating = True
    'Application.DisplayAlerts = True
       Range("Fruit").Select

End Sub

Sub PearSend()
   
   'Application.ScreenUpdating = False
   'Application.DisplayAlerts = False
   
   Sheets("mailer").Select
   Range("PearBody").Select
   
   Dim MailToAddress As String
    MailToAddress = Range("PearTo").Value
   Dim MailCcAddress As String
    MailCcAddress = Range("PearCc").Value
   Dim MailSubject As String
    MailSubject = Range("PearSubject").Value
   Dim PearAttachment1 As String
   Dim PearAttachment2 As String
   Dim PearAttachment3 As String
   Dim PearAttachment4 As String
   
   PearAttachment1 = Range("Pear1").Value
   PearAttachment2 = Range("Pear2").Value
   PearAttachment3 = Range("Pear3").Value
   PearAttachment4 = Range("Pear4").Value
      
      
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
   
   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
'removes existing attachments
For cp = .Item.Attachments.Count To 1 Step -1
.Item.Attachments(cp).Delete
Next cp
'adds mail items to message
      .Item.To = MailToAddress
      .Item.CC = MailCcAddress
      .Item.Subject = MailSubject
      .Item.Attachments.Add PearAttachment1
      .Item.Attachments.Add PearAttachment2
      .Item.Attachments.Add PearAttachment3
      .Item.Attachments.Add PearAttachment4
      .Item.Send
   End With
    
    'Application.ScreenUpdating = True
    'Application.DisplayAlerts = True
       Range("Fruit").Select

End Sub
Sub RaspberrySend()
   
   'Application.ScreenUpdating = False
   'Application.DisplayAlerts = False
   
   Sheets("mailer").Select
   Range("RaspberryBody").Select
   
   Dim MailToAddress As String
    MailToAddress = Range("RaspberryTo").Value
   Dim MailCcAddress As String
    MailCcAddress = Range("RaspberryCc").Value
   Dim MailSubject As String
    MailSubject = Range("RaspberrySubject").Value
   Dim RaspberryAttachment1 As String
   Dim RaspberryAttachment2 As String
   Dim RaspberryAttachment3 As String

   RaspberryAttachment1 = Range("Raspberry1").Value
   RaspberryAttachment2 = Range("Raspberry2").Value
   RaspberryAttachment3 = Range("Raspberry3").Value
     
      
      
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
   
   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
'removes existing attachments
For cp = .Item.Attachments.Count To 1 Step -1
.Item.Attachments(cp).Delete
Next cp
'adds mail items to message
      .Item.To = MailToAddress
      .Item.CC = MailCcAddress
      .Item.Subject = MailSubject
      .Item.Attachments.Add RaspberryAttachment1
      .Item.Attachments.Add RaspberryAttachment2
      .Item.Attachments.Add RaspberryAttachment3
      .Item.Send
   End With
    
    'Application.ScreenUpdating = True
    'Application.DisplayAlerts = True
       Range("Fruit").Select

End Sub

Open in new window

0
stmoritz
Asked:
stmoritz
  • 8
  • 4
2 Solutions
 
Arno KosterCommented:
you can use something like
sub process_fruit
send_email "A", "B", "C", "D", "E", "F", "G"
send_email "A", "B", "C", "D", "E", "F"
send_email "A", "B", "C", "D", "E"
End Sub

Sub send_email(to_address As String, cc_address As String, subject As String, ParamArray attachments())
    msg = "Sending mail to " & to_address & " with cc " & cc_address & " and subject " & subject & " and attachments : "
    For Each att In attachments
        msg = msg & "[" & att & "], "
    Next att
    MsgBox msg
end sub

Open in new window

0
 
Arno KosterCommented:
the send_email subroutine would the resemble
Sub send_email(to_address As String, cc_address As String, subject As String, ParamArray attachments())
      
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
        'removes existing attachments
        For cp = .Item.attachments.Count To 1 Step -1
            .Item.attachments(cp).Delete
        Next cp
        'adds mail items to message
        .Item.To = to_address
        .Item.CC = cc_address
        .Item.subject = subject
        For Each Item In attachments
            .Item.attachments.Add Item
        Next Item
      .Item.Send
   End With
End Sub

Open in new window

0
 
stmoritzAuthor Commented:
Thanks a lot. We're definitely moving in the right direction, exactly what I was looking for!  :o)

A few more questions:

So to call the sub send_email
I would do as follows for example:
send_email "BananaTo", "BananaCc", "BananaSubject", "BananaAttachment1"

1) now where do I set the variables to the value of these named ranges... or am I missing something like BananaTo = Range("BananaTo").Value

2) How do I correctly enter the attachment array (for example attachment path in range Banana1, Banana2, Banana3, Banana4)

3) the named range out of the excel sheet like Range("BananaBody").Select is the respective mailbody. how do i set/define/call this?

many thanks in advance (inreased to 300)
0
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 
Arno KosterCommented:
You're welcome...

The approach was to illustrate the use of the paramarray functionality, you can use the range("name") as before :

1:
send_email range("BananaTo"), range("BananaCC"), range("BananaSubject"), [...]

Open in new window


or assign the range values to variables such as
dim bananato as string
bananato = range("bananato")
send_email bananato, [...]

Open in new window


2:
set it up like this :
Sub send_fruit()
Dim attachments() As String
ReDim attachments(12)
For pos = 1 To 12
attachments(pos) = "Banana" & pos
'-- or use attachments(pos) = Range("Banana" & pos)
Next pos
send_email "to", "CC", "subject", attachments
End Sub

Sub send_email(to_address As String, cc_address As String, subject As String, ParamArray attachments())
    msg = "Sending mail to " & to_address & " with cc " & cc_address & " and subject " & subject & " and attachments : "
    For pos = 1 To UBound(attachments(0))
        msg = msg & "[" & attachments(0)(pos) & "], "
    Next pos
    MsgBox msg
End Sub

Open in new window

0
 
Arno KosterCommented:
for the third question : i am not 100% sure that I understand what you are looking for.

is the question how one can enter a named range in an excel worksheet, or are you looking for a way to extract text information out of a number of cells in this range ?
0
 
stmoritzAuthor Commented:
third question clarification. the selected range is always sent as body of the email. so somewhere I need to add this.

Original Banana code was like this:
Sheets("mailer").Select
Range("BananaBody").Select

so I would use it to call the subroutine in something like
send_email range("BananaTo"), range("BananaCC"), range("BananaSubject"), range("BananaBody")

add it to the bracket:
Sub send_email(to_address As String, cc_address As String, subject As String, ParamArray attachments, MailBody As Range())

and to the code:
MailBody.Select


you think that will work?
0
 
Arno KosterCommented:
no, that will not work, because the paramarray argument must be the last one.

this will work :

sub send_email (to_address as string, cc_address as string, subject as string, body as range, paramarray attachments)
please note that you cannot use the () brackets after range here !

inside of this you indeed can use the code

body.select



0
 
stmoritzAuthor Commented:
seems I am not capable of getting it to work... I upload the sheet here and have increased to 500...
number of attachments is not always equal...


FruitMailer.xls
0
 
Arno KosterCommented:
you need to update the macro's to
Sub SendBananaFactsheets()
Dim attachments() As String
Dim count As Integer
Dim column As String
Dim body As String
Dim pos As Integer

    '-- process bananas
    column = "B"
    count = Range(column & "2")
    ReDim attachments(count)
    For pos = 1 To count
        attachments(pos) = Range(column & pos + 2)
    Next pos
    body = ""
    For pos = 19 To Sheets("Sheet1").UsedRange.Rows.count
        body = body & Sheets("Sheet1").Range(column & pos) & vbCrLf
    Next pos
    
    SendOutFactsheetsByEmail Sheets("Sheet1").Range(column & "17"), Sheets("Sheet1").Range(column & "18"), Sheets("Sheet1").Range(column & "16"), body, attachments
    
    '-- process oranges
    column = "C"
    count = Range(column & "2")
    ReDim attachments(count)
    For pos = 1 To count
        attachments(pos) = Range(column & pos + 2)
    Next pos
    body = ""
    For pos = 19 To Sheets("Sheet1").UsedRange.Rows.count
        body = body & Sheets("Sheet1").Range(column & pos) & vbCrLf
    Next pos
    
    SendOutFactsheetsByEmail Sheets("Sheet1").Range(column & "17"), Sheets("Sheet1").Range(column & "18"), Sheets("Sheet1").Range(column & "16"), body, attachments
    
End Sub

Open in new window


and

Sub SendOutFactsheetsByEmail(to_address As String, cc_address As String, subject As String, body As String, ParamArray attachments())
      
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
        'removes existing attachments
        For cp = .Item.attachments.count To 1 Step -1
            .Item.attachments(cp).Delete
        Next cp
        'adds mail items to message
        .Introduction = body
        .Item.To = to_address
        .Item.CC = cc_address
        .Item.subject = subject
        Set bla = .Item
        For Each Item In attachments(0)
            If Item <> "" Then .Item.attachments.Add Item
        Next Item
      .Item.Send
   End With
End Sub

Open in new window


0
 
Arno KosterCommented:
made a typo :

to be sure that the correct values are used, correct the code from above

count = Range(column & "2")
should have been
count = Sheets("Sheet1").Range(column & "2")

and
attachments(pos) = Range(column & pos + 2)
should have been
attachments(pos) = Sheets("Sheet1").Range(column & pos + 2)

for both banana and orange sections

0
 
stmoritzAuthor Commented:
thaaaaaaank youuuuuuuuuuu! :o))))
0
 
Arno KosterCommented:
you're welcome !
0

Featured Post

How to Use the Help Bell

Need to boost the visibility of your question for solutions? Use the Experts Exchange Help Bell to confirm priority levels and contact subject-matter experts for question attention.  Check out this how-to article for more information.

  • 8
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now