Repeat whole VBA

[Lennw]

Hi All,

I'm very new to VBA's. But with the examples on this forum and other sources, I've created a working VBA.
There are still two features that i need but i don't understand. Repeating the macro and working down a list.

The whole VBA is based on the value in worksheet(SEND)Range("E3"). With that value, the fields of the mail are filled with VLOOKUP.
I have a list in worksheet(NAW3)Column(A) with values that need to be copied to worksheet(SEND)Range("E3").
So the sequence is:
The value of worksheet(NAW3)Range(A1) needs to be copied to worksheet(SEND)Range("E3")
Then the macro has to run, so the email is created and sent.
After that:
The value of worksheet(NAW3)Range(A2(so next cell below previous)) needs to be copied to worksheet(SEND)Range("E3")
Then the macro has to run, so the email is created and sent.

This process needs to be repeated with all following cells/rows in column A until it reaches an empty cell.

If you have any doubts, please let me know!
Could you please adjust the VBA below? Thank you very much in advance!

Sub Mail_Selection_Range_Outlook_Body()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim mailAddress As String
    Dim mailCC As String
    Dim Dealer As String
        
    Dealer = ""
    On Error Resume Next
    Dealer = Application.WorksheetFunction.VLookup(Worksheets("SEND").Range("E3").Value, Worksheets("NAW3").Range("A:G"), 2, False)
    On Error GoTo 0
    
    mailAddress = ""
    On Error Resume Next
    mailAddress = Application.WorksheetFunction.VLookup(Worksheets("SEND").Range("E3").Value, Worksheets("NAW3").Range("A:G"), 5, False)
    On Error GoTo 0
    
    mailCC = ""
    On Error Resume Next
    mailCC = Application.WorksheetFunction.VLookup(Worksheets("SEND").Range("E3").Value, Worksheets("NAW3").Range("A:G"), 6, False)
    On Error GoTo 0
    
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("SEND").Range("A1:K29").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0


    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If


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


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next
    With OutMail
        .To = mailAddress
        .CC = mailCC
        .BCC = ""
        .Subject = "Voorraad overzicht -" & Dealer & "- " & Date
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0


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


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook


    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With


    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With


    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")


    TempWB.Close savechanges:=False


    Kill TempFile


    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[elmer007]

To run your macro for each value in column A, I think you should familiarize yourself with loops. For example, the loop below will continue until the first empty cell in column A is reached:

Sub MacroThatLoops()

Dim myRange As Range
Set myRange = Sheets("Sheet1").Range("A1")

Do Until IsEmpty(myRange) 'The loop will check myRange before each execution, and will stop looping if myRange is empty

    'Code here that will be run during each loop
    'Use myRange to have the current cell in column A
    'The first time this runs, myRange=A1; then the second time, myRange=A2, etc.
    
    MsgBox myRange.Address 'If you run this code on a test sheet with some data in the range A1:A3, this msgbox will show 3 times and have the cell address A1, then A2, then A3
    
    Set myRange = myRange.Offset(1, 0) 'Moves myRange to A2, then A3, etc.
Loop

End Sub

So your setup would be something like:

Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim mailAddress As String
Dim mailCC As String
Dim Dealer As String
Dim myRange as Range

Set myRange = Sheets("NAW3").Range("A1")

Do Until IsEmpty(myRange)

    'Code that sends email goes here

    Set myRange = myRange.Offset(1,0)
Loop

End Sub

 

[elmer007]

So your setup would be something like:

Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim mailAddress As String
Dim mailCC As String
Dim Dealer As String
Dim myRange as Range

Set myRange = Sheets("NAW3").Range("A1")

Do Until IsEmpty(myRange)

    'Code that sends email goes here

    Set myRange = myRange.Offset(1,0)
Loop

End Sub

Sorry, got cut off by a time limit when editing that post... Your loop should start with setting the E3 range like this:

Do Until IsEmpty(myRange)

    Sheets("SEND").Range("E3").Value = myRange.Value
    'Code that sends email goes here

    Set myRange = myRange.Offset(1,0)
Loop