1
\$\begingroup\$

I have an excel that sends an email with all rows with the same name in column (hotel) from sheet list.

I wanted the user to have the possibility to choose which columns are sent and how the data is ordered, in sheet: menu.

As explained here: https://stackoverflow.com/questions/48705516/excel-to-send-emails/48705915?noredirect=1#comment84419832_48705915

However that way it was programmed, it does not allow ordering the columns in the email, or atleast it only orders by the order columns appears in the list sheet.

I tried a solution but it is way much slower:

The whole code:

Sub btnSendMails()

Dim objOutlook As Outlook.Application
Dim strTo As String
Dim strCc As String
Dim strSubject As String
Dim strBody As String
Dim shtMain As Worksheet
Dim shtMails As Worksheet
Dim shtMenu As Worksheet
Dim shtTmp  As Worksheet
Dim iLastRow As Long
Dim iLastColumn As Integer
Dim sHotelName As String
Dim iCl As Integer
Dim myArr() As String
Dim iColumn As Integer
Dim iRow As Long
Dim rng As Range
Set shtMain = Sheets("list")
Set shtMails = Sheets("hotels")
Set shtMenu = Sheets("menu")
Set shtTmp = Sheets("tmp")
Set objOutlook = CreateObject("Outlook.Application")
Application.ScreenUpdating = False
iLastRow = shtMain.Cells(shtMain.Rows.Count, "B").End(xlUp).Row
iLastColumn = shtMenu.Cells(3, shtMenu.Columns.Count).End(xlToLeft).Column
ilastrowmail = shtMails.Cells(shtMails.Rows.Count, "B").End(xlUp).Row

shtMain.Range("A1:AO" & iLastRow).Sort key1:=shtMain.Range("B1:N" & iLastRow), _
   order1:=xlAscending, Header:=xlYes


ReDim Preserve myArr(5)

j = 0
shtTmp.Cells.ClearContents

For i = 3 To iLastColumn
    myArr(j) = shtMenu.Cells(3, i)
    j = j + 1
    ReDim Preserve myArr(j)
Next i
For i = 0 To UBound(myArr)
    shtTmp.Cells(1, i + 1) = myArr(i)
Next i

For i = 2 To iLastRow
    sHotelName = Left(shtMain.Cells(i, 2), InStr(shtMain.Cells(i, 2), "(") - 2)
    iRow = 2
    For j = i To iLastRow
        iColumn = 1
        For iCl = 2 To 41
            If IsInArray(shtMain.Cells(1, iCl), myArr) Then
                shtTmp.Cells(1, iColumn) = shtMain.Cells(1, iCl)
                shtTmp.Cells(iRow, iColumn) = shtMain.Cells(j, iCl)
                If shtTmp.Cells(1, iColumn) = "Obs" Then shtTmp.Cells(iRow, iColumn) = shtTmp.Cells(iRow, iColumn) & vbNewLine
                iColumn = iColumn + 1
            End If
        Next iCl
        shtTmp.Cells(iRow, 1) = sHotelName
        On Error GoTo Resume1
        If Left(shtMain.Cells(j + 1, 2), InStr(shtMain.Cells(j + 1, 2), "(") - 2) = sHotelName Then
            iRow = iRow + 1
        Else
Resume1:
            For r = 2 To ilastrowmail
                If UCase(sHotelName) = shtMails.Cells(r, 3) Then
                    strTo = shtMails.Cells(r, 4)
                    Exit For
                End If
            Next r
            If strTo = "" Then
                MsgBox "Email not found for " & sHotelName & vbNewLine & "Macro will resume."
            Else
            shtTmp.Select
            On Error GoTo Skipit
            HeaderNames = myArr
                For l = 0 To UBound(HeaderNames)
                    Columns(Rows(1).Find(HeaderNames(l), , xlValues, xlWhole).Column).Cut
                    If Rows(1).Find(HeaderNames(l), , xlValues, xlWhole).Column = l + 1 Then
                    Else
                        Columns(l + 1).Insert
                    End If
Skipit:
                Next
                Set rng = shtTmp.Range(shtTmp.Cells(1, 1), shtTmp.Cells(iRow, UBound(myArr) + 1))
                strSubject = shtMenu.Cells(13, 3)
                strBody = shtMenu.Cells(7, 3) & "<br>" & RangetoHTML(rng) & "<br>" & shtMenu.Cells(10, 3)
                Call createMail(objOutlook, strTo, strSubject, strBody)
            End If
            strTo = ""
            shtTmp.Cells.ClearContents
            For r = 0 To UBound(myArr)
                shtTmp.Cells(1, r + 1) = myArr(r)
            Next r
            i = j
            Exit For
        End If
    Next j
Next i




If shtMenu.Cells(15, 6) <> "x" Then
Exit Sub
End If

Set shtTmp = Sheets("tmpCar")
Dim iRentacar As Integer
Set shtMails = Sheets("rentacar")
iLastRow = shtMain.Cells(shtMain.Rows.Count, "B").End(xlUp).Row
iLastColumn = shtMenu.Cells(17, shtMenu.Columns.Count).End(xlToLeft).Column
ilastrowmail = shtMails.Cells(shtMails.Rows.Count, "B").End(xlUp).Row

shtMain.Range("A1:AO" & iLastRow).Sort key1:=shtMain.Range("B1:N" & iLastRow), _
   order1:=xlAscending, Header:=xlYes


ReDim myArr(5)

j = 0
shtTmp.Cells.ClearContents

For i = 3 To iLastColumn
    myArr(j) = shtMenu.Cells(17, i)
    j = j + 1
    ReDim Preserve myArr(j)
Next i
For i = 0 To UBound(myArr)
    shtTmp.Cells(1, i + 1) = myArr(i)
Next i

For iCl = 2 To 41
    If shtMain.Cells(1, iCl) = "Rent a car" Then
        iRentacar = iCl
        Exit For
    End If
Next iCl
shtTmp.Select
For i = 2 To iLastRow
    If shtMain.Cells(i, iRentacar) <> "" And shtMain.Cells(i, iRentacar) <> 0 Then
        sHotelName = Left(shtMain.Cells(i, 2), InStr(shtMain.Cells(i, 2), "(") - 2)
        iRow = 2
        For j = i To iLastRow
            iColumn = 1
            For iCl = 2 To 41
                If IsInArray(shtMain.Cells(1, iCl), myArr) Then
                    shtTmp.Cells(1, iColumn) = shtMain.Cells(1, iCl)
                    shtTmp.Cells(iRow, iColumn) = shtMain.Cells(j, iCl)
                    If shtTmp.Cells(1, iColumn) = "Obs" Then shtTmp.Cells(iRow, iColumn) = shtTmp.Cells(iRow, iColumn) & vbNewLine
                    iColumn = iColumn + 1
                End If
            Next iCl
            shtTmp.Cells(iRow, 1) = sHotelName
            On Error GoTo Resume2
            If Left(shtMain.Cells(j + 1, 2), InStr(shtMain.Cells(j + 1, 2), "(") - 2) = sHotelName Then
                iRow = iRow + 1
            Else
Resume2:
                For r = 2 To ilastrowmail
                    If shtMain.Cells(i, iRentacar + 1) = shtMails.Cells(r, 2) Then
                        strTo = shtMails.Cells(r, 3)
                        Exit For
                    End If
                Next r
                If strTo = "" Then
                    MsgBox "Email not found for " & sHotelName & vbNewLine & "Macro will resume."
                Else
                On Error GoTo Skipit2
                HeaderNames = myArr
                    For l = 0 To UBound(HeaderNames)
                        Application.CutCopyMode = False
                        Columns(Rows(1).Find(HeaderNames(l), , xlValues, xlWhole).Column).Cut
                        If l + 1 = Rows(1).Find(HeaderNames(l), , xlValues, xlWhole).Column Then
                        Else
                        Columns(l + 1).Insert
                        End If
Skipit2:
                    Next
                    Set rng = shtTmp.Range(shtTmp.Cells(1, 1), shtTmp.Cells(iRow, UBound(myArr) + 1))
                    strSubject = shtMenu.Cells(27, 3)
                    strBody = shtMenu.Cells(21, 3) & "<br>" & RangetoHTML(rng) & "<br>" & shtMenu.Cells(24, 3)
                    Call createMail(objOutlook, strTo, strSubject, strBody)
                End If
                strTo = ""
                shtTmp.Cells.ClearContents
                For r = 0 To UBound(myArr)
                    shtTmp.Cells(1, r + 1) = myArr(r)
                Next r
                i = j
                Exit For
            End If
        Next j
    End If
Next i
shtTmp.Select
Application.ScreenUpdating = True
End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

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

Sub createMail(objOutlook As Outlook.Application, strTo As String, strSubject As String, strBody As String)

Dim objMail As Outlook.MailItem

Set objMail = objOutlook.CreateItem(0)


With objMail
    .To = strTo
    .Subject = strSubject
    .HTMLBody = Replace(strBody, "0in", "1in")
    .Save
    ' If you want to send:
    '.Send
End With

Set objMail = Nothing

End Sub

The main difference is this bit of code:

shtTmp.Select
On Error GoTo Skipit
HeaderNames = myArr
For l = 0 To UBound(HeaderNames)
Columns(Rows(1).Find(HeaderNames(l), , xlValues, xlWhole).Column).Cut
If Rows(1).Find(HeaderNames(l), , xlValues, xlWhole).Column = l + 1 Then
  Else
  Columns(l + 1).Insert
End If
Skipit:
Next
Set rng = shtTmp.Range(shtTmp.Cells(1, 1), shtTmp.Cells(iRow, UBound(myArr) + 1))

Is their anyway I can do this in a more quicker fashion?

\$\endgroup\$
  • \$\begingroup\$ If you just need to user to pick columns, why not build an array and then input it as a table in outlook? It looks like you're doing a lot more than that. \$\endgroup\$ – Raystafarian Feb 12 '18 at 1:53
  • \$\begingroup\$ I would use the ADODB..Recordset.GetString method to create the HTML Table. Here is the best reference that I could find: ADO Book Link. The code is written for an ASP but is easy enough to convert to VBA. Using this method you could simply change the order of the columns in your SQL query. \$\endgroup\$ – user109261 Feb 12 '18 at 8:42
2
\$\begingroup\$

It seems to me like this is being run from Excel, right? Click a button in excel, use outlook to send an email.

Variable Naming

Without getting into semantics about it, you're using Hungarian notation e.g.

strSubj
iLastRow

You want to tell me that the subject is a string and the lastrow is an integer? But, what else can a subject be? Or a row number? Putting the notation before the name of the variable just isn't very useful, if you think about. Why not instead give them better names?

emailSubject
lastRow

Likewise, you have some shtMain type variables, worksheets I presume.

Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet. You can get rid of all those variables, give the sheets proper names and voila, shorter code.

What about this variable?

iRentacar

Is it number of cars rented? Is it boolean? Is it what kind of car? I've no idea! It's set to a column number, so I'd imagine it's the column of the cars?

Variable Declaration

Always turn on Option Explicit. You can have it automatically by going to Tools -> Options in the VBE and checking the Require Variable Declaration option. This way if you have any variables not defined, the compiler will let you know. Let's see what isn't defined -

ilastrowmail, i, j, r, Headernames, l,

For a start. I don't like using i and j and instead call them whatever index they are, but there's nothing wrong with using them. But what is r and for that matter, is that "L" a 1? Avoid single character variables for that reason alone.

Magic Numbers

These for example -

  • For i = 3 To iLastColumn
  • sHotelName = Left(shtMain.Cells(i, 2), InStr(shtMain.Cells(i, 2), "(") - 2)
  • For iCl = 2 To 41

It'd be better to make a constant at the top with a name describing the number. Right now, why does i start at three? And what is 2 to 41?

Const FIRST_DATA_ROW as Long = 2
Const FIRST_COLUMN as Long = 2
Const LAST_COLUMN as Long = 42

Now you have something like

For i = FIRST_DATA_ROW to lastRow
For columnIndex = FIRST_COLUMN To LAST_COLUMN

Now we're cooking!

Binding

Dim objOutlook As Outlook.Application
Set objOutlook = CreateObject("Outlook.Application")

You're mixing and matching here. If you use late binding

Dim outlookApp as Object
Set outlookApp = CreateObject("Outlook.Application")

Whereas if you use early binding

Dim outlookApp as Outlook.Application
Set outlookApp = New Outlook.Application

I'd suggest early binding on something like this, but it's your call, just pick one and stick with it. Remember though, with early binding you must set the reference in the VBE for it to work, and any user must always have that reference checked.

Calling a routine or function

Call createMail(objOutlook, strTo, strSubject, strBody)

can just be shortened to

CreateMail outlookApp, emailToRecipient, emailSubject, emailBody

No need to Call anymore and since it's a sub you don't need parenthesis.

On this, you've automatically called your argument ByRef or by reference, thus passing the variable itself. This is tricky and you should always try to pass ByVal. You didn't pick ByRef, but excel did it for you, so you take charge! Try to find every variable being passed and see if ByVal will work for them, almost always it will.

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean

Becomes

Function IsInArray(ByVal stringToBeFound As String, ByVal arrayToSearch As Variant) As Boolean

Uh oh, what's going on here?

 Function RangetoHTML(rng As Range)

A Function should return a value. Remember that ByRef thing we were talking about? You got lucky here. Either a Function returns something or a Sub does something. This -

 strBody = shtMenu.Cells(21, 3) & "<br>" & RangetoHTML(rng) & "<br>" & shtMenu.Cells(24, 3)

Means probably Function RangetoHtml(ByVal targetRange as Range) as String is more appropriate. Just make sure in the function you set it to something before you exit

Private Function RangeToHtml(ByVal targetRange as Range) as String
    'Do stuff to targetRange
    RangeToHtml = 'whatever it needs to be
End Function

I also see that string "<br>" in there. Perfect time for

 Const PARAGRAPH_BREAK as String = "<br>"

Now

 emailBody= Menu.Cells(21, 3) & PARAGRAPH_BREAK & RangetoHTML(targetRange) & PARAGRAPH_BREAK & Menu.Cells(24, 3)

Constants can also be used for strings ".htm", "\", "temp" etc. You get the gist.

.HTMLBody = Replace(strBody, "0in", "1in")
.HtmlBody = Replace(emailBody, STRING_TO_REPLACE, REPLACEMENT_STRING)

Cleanup

Kill TempFile

Ouch. That's rough. What are you killing? Are you deleting something? Closing something? Find a better way to do that.

Because of the way VBA is, you don't really need to cleanup

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

It's fine if you want to, but I don't know of any benefit.

strTo = ""

Better off to use the VBA constant for this `vbNullString

emailToRecipient = vbNullString

A lot cleaner, don't you think?

Refactoring

   For i = 2 To iLastRow
        If shtMain.Cells(i, iRentacar) <> "" And shtMain.Cells(i, iRentacar) <> 0 Then
            sHotelName = Left(shtMain.Cells(i, 2), InStr(shtMain.Cells(i, 2), "(") - 2)
            iRow = 2
            For j = i To iLastRow
                iColumn = 1
                For iCl = 2 To 41
                    If IsInArray(shtMain.Cells(1, iCl), myArr) Then
                        'stuff
                    End If
                Next iCl
                shtTmp.Cells(iRow, 1) = sHotelName
                On Error GoTo Resume2
                If Left(shtMain.Cells(j + 1, 2), InStr(shtMain.Cells(j + 1, 2), "(") - 2) = sHotelName Then
                    iRow = iRow + 1
                Else
Resume2:
                    For r = 2 To ilastrowmail
                        If shtMain.Cells(i, iRentacar + 1) = shtMails.Cells(r, 2) Then
                            'stuff
                        End If
                    Next r
                    If strTo = "" Then
                        MsgBox "Email not found for " & sHotelName & vbNewLine & "Macro will resume."
                    Else
                        On Error GoTo Skipit2
                        HeaderNames = myArr
                        For l = 0 To UBound(HeaderNames)

                            If l + 1 = Rows(1).Find(HeaderNames(l), , xlValues, xlWhole).Column Then
                            Else
                                Columns(l + 1).Insert
                            End If
Skipit2:
                        Next
                        'stuff
                        Call createMail(objOutlook, strTo, strSubject, strBody)
                    End If
                    strTo = ""
                    shtTmp.Cells.ClearContents
                    For r = 0 To UBound(myArr)
                        'stuff
                    Next r
                    i = j
                    Exit For
                End If
            Next j
        End If
    Next i

Holy Arrow Code Batman! I don't even know if I got all those loops closed in my cutout. With all this nesting and all these conditions, it's very hard to understand what's happening. Try to break some of that out into Functions so it's easier to understand. One example would be this particular loop

        For iCl = 2 To 41
            If IsInArray(shtMain.Cells(1, iCl), myArr) Then
                shtTmp.Cells(1, iColumn) = shtMain.Cells(1, iCl)
                shtTmp.Cells(iRow, iColumn) = shtMain.Cells(j, iCl)
                If shtTmp.Cells(1, iColumn) = "Obs" Then shtTmp.Cells(iRow, iColumn) = shtTmp.Cells(iRow, iColumn) & vbNewLine
                iColumn = iColumn + 1
            End If
        Next iCl

Could just be

            For iCl = STARTING_COLUMN To ENDING_COLUMN
                If IsInArray(shtMain.Cells(1, iCl), myArr) Then MoveStuff targetSheet, targetColumn
            Next iCl

Sub MoveStuff(ByVal targetSheet as Worksheet, ByVal targetColumn as Long)
     'do anything you want!
End Sub

Error Handling

Labels aren't the greatest thing in the world, but given you have to number your labels ("Resume1, Resume2, ...") would indicate to me that you need to find a better way to handle those errors

On Error GoTo "label"
On Error Resume Next
On Error GoTo 0

You might want to trap those errors instead of just waiting for the code to have an error.

    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete

I'm not even sure what's happening here, there's no loop. You just want to make sure the drawing objects are deleted? Why not something like

If .DrawingObjects Then
   .DrawingObjects.Delete
End if

Or even just

If .DrawingObjects then .DrawingObjects.Delete

Now you won't have to handle the error, it won't happen because you've trapped the way in which you might get an error and you've handled it before an exception is raised!

You'll also note another trick, if your If is evaluating a Boolean, just use the fact that it will be True/False to proceed with your statement.

Integers

Integers - integers are obsolete. According to msdn VBA silently converts all integers to long.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.