Private Proxies – Buy Cheap Private Elite USA Proxy + 50% Discount!Private Proxies – Buy Cheap Private Elite USA Proxy + 50% Discount!Private Proxies – Buy Cheap Private Elite USA Proxy + 50% Discount!Private Proxies – Buy Cheap Private Elite USA Proxy + 50% Discount!
    0
  •   was successfully added to your cart.
  • Home
  • Buy proxies
  • Extra features
  • Help
  • Contact
  • Login
  • 50% OFF
    BUY NOW!
    50
    PROXIES
    $19
    --------------------
    BUY NOW!
    BUY NOW!
    BUY NOW!
    BUY NOW!
    BUY NOW!
    $29
    $49
    $109
    $179
    $299
    --------------------
    --------------------
    --------------------
    --------------------
    --------------------
    PROXIES
    PROXIES
    PROXIES
    PROXIES
    PROXIES
    100
    200
    500
    1,000
    2,000
    TOP SELLER
    BEST VALUE
    For All Private Proxies!

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?

✓ Extra quality

ExtraProxies brings the best proxy quality for you with our private and reliable proxies

✓ Extra anonymity

Top level of anonymity and 100% safe proxies – this is what you get with every proxy package

✓ Extra speed

1,ooo mb/s proxy servers speed – we are way better than others – just enjoy our proxies!

50 proxies

$19/month

50% DISCOUNT!
$0.38 per proxy
✓ Private
✓ Elite
✓ Anonymous
Buy now

100 proxies

$29/month

50% DISCOUNT!
$0.29 per proxy
✓ Private
✓ Elite
✓ Anonymous
Buy now

200 proxies

$49/month

50% DISCOUNT!
$0.25 per proxy
✓ Private
✓ Elite
✓ Anonymous
Buy now

500 proxies

$109/month

50% DISCOUNT!
$0.22 per proxy
✓ Private
✓ Elite
✓ Anonymous
Buy now

1,000 proxies

$179/month

50% DISCOUNT!
$0.18 per proxy
✓ Private
✓ Elite
✓ Anonymous
Buy now

2,000 proxies

$299/month

50% DISCOUNT!
$0.15 per proxy
✓ Private
✓ Elite
✓ Anonymous
Buy now

USA proxy location

We offer premium quality USA private proxies – the most essential proxies you can ever want from USA

100% anonymous

Our proxies have TOP level of anonymity + Elite quality, so you are always safe and secure with your proxies

Unlimited bandwidth

Use your proxies as much as you want – we have no limits for data transfer and bandwidth, unlimited usage!

Superfast speed

Superb fast proxy servers with 1,000 mb/s speed – sit back and enjoy your lightning fast private proxies!

99,9% servers uptime

Alive and working proxies all the time – we are taking care of our servers so you can use them without any problems

No usage restrictions

You have freedom to use your proxies with every software, browser or website you want without restrictions

Perfect for SEO

We are 100% friendly with all SEO tasks as well as internet marketing – feel the power with our proxies

Big discounts

Buy more proxies and get better price – we offer various proxy packages with great deals and discounts

Premium support

We are working 24/7 to bring the best proxy experience for you – we are glad to help and assist you!

Satisfaction guarantee

24/7 premium support, free proxy activation and 100% safe payments! Best reliability private proxies for your needs!

Best Proxy Packs

  • 2,000 Private Proxies $600.00 $299.00 / month
  • 1,000 Private Proxies $360.00 $179.00 / month

Quick Links

  • More information
  • Contact us
  • Privacy Policy
  • Terms and Conditions

Like And Follow Us


Copyright ExtraProxies.com | All Rights Reserved.
  • Checkout
  • Contact
  • Help
  • Home
  • My Account
  • My Cart
  • News
  • Privacy Policy
  • Proxy features
  • Proxy packs
  • Terms and Conditions
Private Proxies – Buy Cheap Private Elite USA Proxy + 50% Discount!
    0 items