堆棧內存溢出
  簡體   English   中英

Excel發送電子郵件

[英]Excel to send emails

 原文  2018-02-09 12:08:52  4   1    excel/ vba/ excel-vba/ email

問題描述

嗨，我有一個Excel，可以發送一個電子郵件，其中包含工作表列表中列（酒店）中所有具有相同名稱的行。

我希望用戶可以在工作表：菜單中選擇發送哪些列以及如何排序數據。 用戶還可以在表格和電子郵件主題之前和之后的正文中定義文本。

在此處輸入圖片說明

宏運行良好，但現在我想在電子郵件中使用“ Operador”列，並且發送的電子郵件發送得不好，Operador的值不正確，日期采用另一種格式： 在此處輸入圖片說明

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列：租車和服務（在數據列表表中），如果它在該單元格（租車）中有值，我們想要一個規則，即可以將行發送到旅館，然后根據另一個單元格（服務）中的值向另一個電子郵件發送不同的電子郵件。 我們提供服務列表以及相應的電子郵件和“租車電子郵件”列。

1 個解決方案

解決方案1
 2 已采納  2018-02-09 12:31:36

如果我理解正確，則只需將您的代碼替換為以下內容，即可顯示您期望的日期： 

Sub btnSendMails()
Dim strTo As String, strCc As String, strSubject As String, strBody As String, sHotelName As String, myArr() As String, DateValue As String, DateValue2 As String, DateValue3 As String
Dim iLastRow As Long, iLastColumn As Long, iColumn As Long, iRow As Long, iCl As Long, iHotel As Long, iPos As Long, i As Long
Dim rng As Range
Dim shtMain As Worksheet: Set shtMain = Sheets("list")
Dim shtMails As Worksheet: Set shtMails = Sheets("hotels")
Dim shtMenu As Worksheet: Set shtMenu = Sheets("menu")
Dim shtTmp  As Worksheet: Set shtTmp = Sheets("tmp")
Dim objOutlook As Outlook.Application
Set objOutlook = CreateObject("Outlook.Application")

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

For i = 2 To iLastRow
    DateValue = shtMain.Cells(i, 3)
    shtMain.Cells(i, 3).NumberFormat = "@"
    shtMain.Cells(i, 3).Value = DateValue
    DateValue2 = shtMain.Cells(i, 9)
    shtMain.Cells(i, 9).NumberFormat = "@"
    shtMain.Cells(i, 9).Value = DateValue2
    DateValue3 = shtMain.Cells(i, 23)
    shtMain.Cells(i, 23).NumberFormat = "@"
    shtMain.Cells(i, 23).Value = DateValue3
Next i

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

        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

If shtMenu.Cells(15, 6) <> "x" Then
Exit Sub
End If

Set shtTmp = Sheets("tmpCar")
Dim iRentacar As Long
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
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

我只是添加了一個循環，以將日期格式設置為字符串，以便將日期附加到電子郵件中時，格式正確。 我添加的代碼是： 

For i = 2 To iLastRow
    DateValue = shtMain.Cells(i, 3)
    shtMain.Cells(i, 3).NumberFormat = "@"
    shtMain.Cells(i, 3).Value = DateValue
    DateValue2 = shtMain.Cells(i, 9)
    shtMain.Cells(i, 9).NumberFormat = "@"
    shtMain.Cells(i, 9).Value = DateValue2
    DateValue3 = shtMain.Cells(i, 23)
    shtMain.Cells(i, 23).NumberFormat = "@"
    shtMain.Cells(i, 23).Value = DateValue3
Next i

為了解決操作員問題，您只需刪除以下代碼行： 

shtTmp.Cells(iRow, 1) = sHotelName

暫無
暫無

聲明:本站的技術帖子網頁，遵循CC BY-SA 4.0協議，如果您需要轉載，請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.

相關問題 VBA 從 Excel 發送電子郵件 從Excel發送大量電子郵件 如何從Excel發送個性化電子郵件？ Excel根據工作表名稱發送電子郵件 使用 Excel VBA 從表發送電子郵件 導出Excel工作表並將其作為電子郵件發送（循環） 將Excel鏈接到電子郵件。 發送批量電子郵件 Excel VBA在列中向不同的人發送電子郵件 使用VBA-Excel發送已顯示的電子郵件 通過 Excel VBA 一次發送一封電子郵件
相關標簽
 
粵ICP備18138465號  © 2020-2024 STACKOOM.COM