我有Excel代码，可以从工作表列表中的列（酒店）中发送包含所有具有相同名称的行的电子邮件。
我想在工作表菜单中选择要发送的列以及数据的排序方式。
如下所述： Excel to send emails
它的编程方式不允许对电子邮件中的列进行排序，或者至少它只按订单列中的订单显示在表单列表中。
我尝试了一个解决方案，但速度要慢得多：
整个代码：
Undefined index: item主要区别在于这段代码：
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
他们无论如何我能以更快的方式做到这一点吗？