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?