【发布时间】：2018-02-09 12:08:52
【问题描述】：
您好，我有一个 excel，它发送一封电子邮件，其中包含工作表列表中列（酒店）中所有同名的行。
我希望用户能够在 sheet: menu 中选择发送哪些列以及数据的排序方式。用户还可以在表格前后的正文中定义文本以及电子邮件的主题。
宏运行良好，但现在我想在电子邮件中使用“操作员”列，并且发送的电子邮件发送不正确，操作员没有正确的值并且日期采用另一种格式：
excel文件在这里： https://www.dropbox.com/s/d5b2wc3w5db2m01/Email%20das%20reservas.xlsm?dl=1
VBA 在这里：
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
Dim iHotel As Integer
Set shtMain = Sheets("list")
Set shtMails = Sheets("hotels")
Set shtMenu = Sheets("menu")
Set shtTmp = Sheets("tmp")
Set objOutlook = CreateObject("Outlook.Application")
Dim iPos As Integer
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
Application.ScreenUpdating = False
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 iCl = 2 To 41
If shtMain.Cells(1, iCl) = "Hotel" Then
iHotel = iCl
Exit For
End If
Next iCl
For i = 3 To iLastColumn
myArr(j) = UCase(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
If InStr(shtMain.Cells(i, iHotel), "(") = 0 Then
iPos = 50
Else
iPos = InStr(shtMain.Cells(i, iHotel), "(")
End If
sHotelName = Left(shtMain.Cells(i, iHotel), iPos - 2)
iRow = 2
For j = i To iLastRow
iColumn = 1
For iCl = 1 To 41
If IsInArray(UCase(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, iHotel), iPos - 2) = sHotelName Then
iRow = iRow + 1
Else
Resume1:
For r = 2 To ilastrowmail
If UCase(sHotelName) = UCase(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
Set rng = shtTmp.Range(shtTmp.Cells(1, 1), shtTmp.Cells(iRow, UBound(myArr)))
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
shtTmp.Select
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
Erase myArr
ReDim myArr(1)
j = 0
shtTmp.Cells.ClearContents
For i = 3 To iLastColumn
myArr(j) = UCase(shtMenu.Cells(17, i))
Debug.Print myArr(j)
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
For i = 2 To iLastRow
If shtMain.Cells(i, iRentacar) <> "" And shtMain.Cells(i, iRentacar) <> 0 Then
If InStr(shtMain.Cells(j + 1, iHotel), "(") = 0 Then
iPos = 50
Else
iPos = InStr(shtMain.Cells(i, iHotel), "(")
End If
sHotelName = Left(shtMain.Cells(i, iHotel), iPos - 2)
iRow = 2
For j = i To iLastRow
iColumn = 1
For iCl = 1 To 41
If IsInArray(UCase(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, iHotel), iPos - 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 "Rent a Car service not found for " & sHotelName & vbNewLine & "Macro will resume."
Else
Set rng = shtTmp.Range(shtTmp.Cells(1, 1), shtTmp.Cells(iRow, UBound(myArr)))
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
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = False
For i = 0 To UBound(arr)
If stringToBeFound = arr(i) Then
IsInArray = True
Exit Function
End If
Next i
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
Application.ScreenUpdating = False
End Sub
我尝试的是检测酒店列的位置，因此与我添加变量 iHotel 并在多次迭代中使用它之前的代码相比......
提前谢谢你！！
注意：我们还有 2 列：rent-a-car 和 service，（在数据列表中）如果它在那个单元格（rent-a-car）中有一个值，我们想要一个规则，该行可以被发送到酒店并根据另一个单元格（服务）中的值向另一个电子邮件发送不同的电子邮件。我们有服务列表和相应的电子邮件以及租车电子邮件的列。
【问题讨论】：
-
请将相关代码部分添加到您的问题中，并将其格式化为代码块。大多数人不会从未知来源下载启用宏的文件，而且当下载消失时，这个问题对于更多的读者来说将毫无用处。还要展示你已经为实现目标所做的努力，因为大多数人会很好地帮助你完成你的代码，但大多数人不会为你完成所有的工作。
-
已添加，希望够用了...