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

[DavidAC]

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

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

 

[JEC]

This is enough:

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]

thanks for that unfortunately i am getting a run time error 9 subscript out of range

This is enough:

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]

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]

Hi,

try

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