use input box to select columns I want excel to use to populate Outlook address field

DavidAC

Board Regular
Joined
Feb 10, 2003
Messages
130
good evening, I have 2 questions to ask regarding excel and outlook

1. Below is the vba code i am using below to select a column of email addresses i need to populate outlook with. However in the spreadsheet i have 10 different columns with over 300 names in each column as different mails go to different people. how do i create an input box to identify which column i want to select?
2.rather than creating a new mail i want it to select from a template on our server.

any assistance always greatly received

VBA Code:
Sub SendEmail()

Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String


'Create Outlook object
Set OutlookApp = New Outlook.Application

'Loop through the rows
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr1 = EmailAddr1 & ";" & cell.Value
End If
Next


Msg = Msg & "Please review the following." & vbCrLf
Subj = "LEAD REFERRAL-"


'Create Mail Item and view before sending
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.SentOnBehalfOfName = "abcd@1234.com"
.BCC = EmailAddr1
.Subject = Subj
.Body = Msg & vbCrLf
.Display
End With

End Sub
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

JEC

Well-known Member
Joined
Aug 21, 2021
Messages
566
Office Version
  1. 365
Platform
  1. Windows
This is enough:

VBA Code:
Sub smail()
 col = Application.InputBox("Choose columnnumber", "test", , , , , , 1)
 With CreateObject("Outlook.Application").CreateItem(0)
     .To = Join(Application.Transpose(Sheets("Emails").ListObjects("Emails").ListColumns(col).DataBodyRange), ";")
     .Subject = ""
     .Body = ""
     .display
  End With
End Sub
 

DavidAC

Board Regular
Joined
Feb 10, 2003
Messages
130
thanks for that unfortunately i am getting a run time error 9 subscript out of range
This is enough:

VBA Code:
Sub smail()
 col = Application.InputBox("Choose columnnumber", "test", , , , , , 1)
 With CreateObject("Outlook.Application").CreateItem(0)
     .To = Join(Application.Transpose(Sheets("Emails").ListObjects("Emails").ListColumns(col).DataBodyRange), ";")
     .Subject = ""
     .Body = ""
     .display
  End With
End Sub
 

JEC

Well-known Member
Joined
Aug 21, 2021
Messages
566
Office Version
  1. 365
Platform
  1. Windows
thanks for that unfortunately i am getting a run time error 9 subscript out of range
Ofcourse you have to change names in the code. Try to fit this code into your file
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,932
Office Version
  1. 2019
Platform
  1. Windows
Hi,

try

Rich (BB code):
Sub SendEmail()
    
    Dim OutlookApp  As Outlook.Application
    Dim MItem       As Outlook.MailItem
    Dim cell        As Range, objRange As Range
    Dim Subj        As String, EmailAddr1 As String
    Dim Recipient   As String
    Dim Msg         As String
    
    On Error Resume Next
    Set objRange = Application.InputBox("Select Column", "Select Column", , , , , , 8)
    On Error GoTo 0
    'cancel pressed
    If objRange Is Nothing Then Exit Sub
    
    'Create Outlook object
    Set OutlookApp = New Outlook.Application
    
    'Loop through the rows
    For Each cell In Columns(objRange(1).Column).Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value Like "*@*" Then
            EmailAddr1 = EmailAddr1 & ";" & cell.Value
        End If
    Next
    
    Msg = Msg & "Please review the following." & vbCrLf
    Subj = "LEAD REFERRAL-"
    
    'Create Mail Item and view before sending
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .SentOnBehalfOfName = "abcd@1234.com"
        .BCC = EmailAddr1
        .Subject = Subj
        .Body = Msg & vbCrLf
        .Display
    End With
    
End Sub

Dave
 
Solution

Forum statistics

Threads
1,148,173
Messages
5,745,179
Members
423,931
Latest member
thangvan114

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top