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?