Limit user selected range

B

Ben AFF

Board Regular
Joined
Sep 21, 2023
Messages
55
Office Version
  1. 365
Platform
  1. Windows
Hi, I have a Macro that allows the user to send email based on selection of rows on a spreadsheet.
I want to limit the range within which the user selection is valid to columns A:B only.
Please can you help me? Thank you.

VBA Code: 
Sub ExcelToOutlookSR()
Dim mApp As Object
Dim mMail As Object
Dim SendToMail As String
Dim MailSubject As String
Dim mMailBody As String
For Each r In Selection
SendToMail = Range("M" & r.Row)
MailSubject = Range("K" & r.Row)
mMailBody = Range("L" & r.Row)
Set mApp = CreateObject("Outlook.Application")
Set mMail = mApp.CreateItem(0)
With mMail
.To = SendToMail
.Subject = MailSubject
.Body = mMailBody
.Display
End With
Next r
End Sub
 
Sort by date Sort by votes

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Ben AFF said:
The idea is to create and additional button to action the macro for bulk send without doing any selection,
Click to expand...
What button? a ribbon button or an activex button on the sheet?

Try this:
You need to change the sheet name to suit
VBA Code: 
Sub ExcelToOutlookSR_3()
Dim mApp As Object
Dim mMail As Object
Dim SendToMail As String
Dim MailSubject As String
Dim mMailBody As String
Dim r As Range, n As Long
Dim d As Object, f As Object
Dim tx As String
Dim x, ary, g

    Sheets("Sheet1").Activate 'change the sheet name to suit

    Set d = CreateObject("scripting.dictionary"):        d.CompareMode = vbTextCompare
    Set f = CreateObject("scripting.dictionary"):        d.CompareMode = vbTextCompare

    With Range("E2", Cells(Rows.Count, "E").End(xlUp))
        For Each r In .Cells
            If Cells(r.Row, "N") = Empty Then f(r.Value) = Empty
        Next
        
        For Each r In .Cells
            tx = r.Value
            If f.Exists(tx) Then
                If Not d.Exists(tx) Then
                    d(tx) = r.Row
                Else
                    d(tx) = d(tx) & " " & r.Row
                End If
            End If
        Next
   End With
   
        For Each x In d
            ary = Split(d.Item(x), " ")
            SendToMail = Range("M" & ary(0))
            MailSubject = Range("K" & ary(0))
            tx = ""
            For Each g In ary
                tx = tx & vbLf & Range("L" & g)
            Next
            mMailBody = Mid(tx, 2)
'            Debug.Print mMailBody
            Set mApp = CreateObject("Outlook.Application")
            Set mMail = mApp.CreateItem(0)
            With mMail
                .To = SendToMail
                .Subject = MailSubject
                .Body = mMailBody
                .Display
            End With
        Next

End Sub
 
Upvote 0
Solution
Akuini said:
What button? a ribbon button or an activex button on the sheet?

Try this:
You need to change the sheet name to suit
VBA Code: 
Sub ExcelToOutlookSR_3()
Dim mApp As Object
Dim mMail As Object
Dim SendToMail As String
Dim MailSubject As String
Dim mMailBody As String
Dim r As Range, n As Long
Dim d As Object, f As Object
Dim tx As String
Dim x, ary, g

    Sheets("Sheet1").Activate 'change the sheet name to suit

    Set d = CreateObject("scripting.dictionary"):        d.CompareMode = vbTextCompare
    Set f = CreateObject("scripting.dictionary"):        d.CompareMode = vbTextCompare

    With Range("E2", Cells(Rows.Count, "E").End(xlUp))
        For Each r In .Cells
            If Cells(r.Row, "N") = Empty Then f(r.Value) = Empty
        Next
       
        For Each r In .Cells
            tx = r.Value
            If f.Exists(tx) Then
                If Not d.Exists(tx) Then
                    d(tx) = r.Row
                Else
                    d(tx) = d(tx) & " " & r.Row
                End If
            End If
        Next
   End With
  
        For Each x In d
            ary = Split(d.Item(x), " ")
            SendToMail = Range("M" & ary(0))
            MailSubject = Range("K" & ary(0))
            tx = ""
            For Each g In ary
                tx = tx & vbLf & Range("L" & g)
            Next
            mMailBody = Mid(tx, 2)
'            Debug.Print mMailBody
            Set mApp = CreateObject("Outlook.Application")
            Set mMail = mApp.CreateItem(0)
            With mMail
                .To = SendToMail
                .Subject = MailSubject
                .Body = mMailBody
                .Display
            End With
        Next

End Sub
Click to expand...
Thank you Akuini, it works perfect.
The Button is form control.


Much appreciated.
 
Upvote 0
You're welcome, glad it works.
Do you want to automatically update col N status to say "Sent" after sending the emails?
 
Upvote 0
Akuini said:
You're welcome, glad it works.
Do you want to automatically update col N status to say "Sent" after sending the emails?
Click to expand...
Yes, Im struggling now to do this.
I have a separated sheet ("Log") where the values of column E&F are copied and then a vlookup in column N where verifies the log sheet.
But I dont know how to send the values back to the Log sheet.
I have try, but does not work?


R
VBA Code: 
ange("E11:F", Cells(Rows.Count, "E:F").End(xlUp)).Copy
   ThisWorkbook.Worksheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


Can you help? :)
 
Upvote 0
Akuini said:
I don't understand this part:
Click to expand...
Hi Akuini,

Sorry.

In the original sheet we have the values in E (Purchase Order) and F(Purchase Order Item) and there is an additional column that concatenates E&F to create a unique ID
The values of E&F need to be copied to a sheet called Log (cols. A&B) where the values are concatenated again in column C of this sheet.
In column N a Vlookup formula looks into column C of the Log sheet and verifies if there is an entry. If yes, the status is SENT, if not the status is Blank.

For this new code you created, the values for E&F Im trying to copy the values of E&F (when I mail is created) to be copied to A&B of the Log sheet, to allow the updating of the status.


Table 1
Purchase Order (A)Purchase Order Item Number (B)Purchase Order Unique ID (C)
ABCDE001ABCDE001
 
Upvote 0
Ben AFF said:
For this new code you created, the values for E&F Im trying to copy the values of E&F (when I mail is created) to be copied to A&B of the Log sheet, to allow the updating of the status.
Click to expand...
Try this:
VBA Code: 
Sub ExcelToOutlookSR_3()
Dim mApp As Object
Dim mMail As Object
Dim SendToMail As String
Dim MailSubject As String
Dim mMailBody As String
Dim r As Range, n As Long
Dim d As Object, f As Object
Dim tx As String
Dim x, ary, g

Application.ScreenUpdating = False
    Sheets("Sheet1").Activate 'change the sheet name to suit
    
    Set d = CreateObject("scripting.dictionary"):        d.CompareMode = vbTextCompare
    Set f = CreateObject("scripting.dictionary"):        d.CompareMode = vbTextCompare

    With Range("E2", Cells(Rows.Count, "E").End(xlUp))
        For Each r In .Cells
            If Cells(r.Row, "N") = Empty Then f(r.Value) = Empty
        Next
        
        For Each r In .Cells
            tx = r.Value
            If f.Exists(tx) Then
                If Not d.Exists(tx) Then
                    d(tx) = r.Row
                Else
                    d(tx) = d(tx) & " " & r.Row
                End If
            End If
        Next
   End With
   
        n = Sheets("Log").Range("A" & Rows.Count).End(xlUp).Row  'last row with data in Sheets("Log") col A
        For Each x In d
            ary = Split(d.Item(x), " ")
            SendToMail = Range("M" & ary(0))
            MailSubject = Range("K" & ary(0))
            tx = ""
            For Each g In ary
                tx = tx & vbLf & Range("L" & g)
            Next
            mMailBody = Mid(tx, 2)
'            Debug.Print mMailBody
            Set mApp = CreateObject("Outlook.Application")
            Set mMail = mApp.CreateItem(0)
            With mMail
                .To = SendToMail
                .Subject = MailSubject
                .Body = mMailBody
                .Display
            End With
            ' the values for E&F Im trying to copy the values of E&F (when I mail is created) to be copied to A&B of the Log sheet, to allow the updating of the status.
            For Each g In ary
                n = n + 1
                Sheets("Log").Range("A" & n).Resize(, 2).Value = Range("E" & g).Resize(, 2).Value
            Next
  
        Next
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Akuini said:
Try this:
VBA Code: 
Sub ExcelToOutlookSR_3()
Dim mApp As Object
Dim mMail As Object
Dim SendToMail As String
Dim MailSubject As String
Dim mMailBody As String
Dim r As Range, n As Long
Dim d As Object, f As Object
Dim tx As String
Dim x, ary, g

Application.ScreenUpdating = False
    Sheets("Sheet1").Activate 'change the sheet name to suit
   
    Set d = CreateObject("scripting.dictionary"):        d.CompareMode = vbTextCompare
    Set f = CreateObject("scripting.dictionary"):        d.CompareMode = vbTextCompare

    With Range("E2", Cells(Rows.Count, "E").End(xlUp))
        For Each r In .Cells
            If Cells(r.Row, "N") = Empty Then f(r.Value) = Empty
        Next
       
        For Each r In .Cells
            tx = r.Value
            If f.Exists(tx) Then
                If Not d.Exists(tx) Then
                    d(tx) = r.Row
                Else
                    d(tx) = d(tx) & " " & r.Row
                End If
            End If
        Next
   End With
  
        n = Sheets("Log").Range("A" & Rows.Count).End(xlUp).Row  'last row with data in Sheets("Log") col A
        For Each x In d
            ary = Split(d.Item(x), " ")
            SendToMail = Range("M" & ary(0))
            MailSubject = Range("K" & ary(0))
            tx = ""
            For Each g In ary
                tx = tx & vbLf & Range("L" & g)
            Next
            mMailBody = Mid(tx, 2)
'            Debug.Print mMailBody
            Set mApp = CreateObject("Outlook.Application")
            Set mMail = mApp.CreateItem(0)
            With mMail
                .To = SendToMail
                .Subject = MailSubject
                .Body = mMailBody
                .Display
            End With
            ' the values for E&F Im trying to copy the values of E&F (when I mail is created) to be copied to A&B of the Log sheet, to allow the updating of the status.
            For Each g In ary
                n = n + 1
                Sheets("Log").Range("A" & n).Resize(, 2).Value = Range("E" & g).Resize(, 2).Value
            Next
 
        Next
Application.ScreenUpdating = True
End Sub
Click to expand...
Hi Akuini, it works but there are to small problems.

1)- It paste de values after 8 blank spaces
2)- The values from column F (001,002) are pasted as (1, 2), but I need the orignal values (001,002).
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
VBA Code to Send Mail to skip blank cells
Replies
1
Views
270
Micron
M
B
  • Solved
Excel Macro to Send Mail to save sent mails rows to Sheet Dynamically
Replies
3
Views
375
Ben AFF
B
L
  • Question Question
VBA: create separate emails for each unique address in selection
Replies
1
Views
540
DanteAmor
DanteAmor
countryfan_nt
  • Question Question
VBA SMTP Sending Outlook mail has no errors, but nothing being sent.
2
Replies
17
Views
677
countryfan_nt
countryfan_nt
M
  • Question Question
Removing self from CC in email generated from Excel.
Replies
0
Views
451
Mr Rice
M

Forum statistics

Threads
1,223,358
Messages
6,171,625
Members
452,412
Latest member
thomasleysen531

Share this page

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
Back
Top