Question

Hello Stackoverflow社区！

我对VBA完全陌生，我遇到了一些问题。

所以我正在尝试将excel单元格导出到特定日期范围内的电子邮件中。程序要求用户输入开始日期和结束日期。然后程序扫描excel表并提取落在日期范围内或落在所选日期的数据。来自Excel工作表的数据放在临时工作簿中，然后从临时工作簿中 - 然后将数据复制到Outlook电子邮件中。然后删除临时工作簿。

请耐心等待 - 对VBA不熟悉我的代码有点到处都是。我一直在尝试从互联网上获得许多解决方案，但他们并没有对我有利。电子邮件打开正确，包含所有预填充的HTML数据（未包含在下面的代码中），但excel单元格中没有任何数据存在。我知道我的函数RangeToHtml需要一些重新工作。任何提示我指向正确方向的提示将不胜感激！

Sub CommandButton4_Click()


   Dim newdate
   newdate = Date
   Dim rng As Range
   Set rng = Nothing
    Dim i As Integer
  newdate = Date - 6
   Set rng = Sheets("Sheet1").Range("A2").SpecialCells(xlCellTypeVisible)


   If rng Is Nothing Then
   MsgBox " The selection is not a range or the sheet is protected." & _
    vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
 End If

    With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

   Set oLook = CreateObject("Outlook.Application")
   Set oMail = oLook.CreateItem(oMailItem)
   ActiveWorkbook.EnvelopeVisible = True

   Dim strA As String, strB As String, strVerify As String



'Set Variable Values
strA = "You're about to send the weekely    OEM PPM Newsletter Update."
strB = "Are you sure you want to send the mail?"
strVerify = strA & vbNewLine & strB

   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
' Attaching the Header to the email'

    Const MyPath = "C:\Users\Jalexan1\Pictures\HEADER.jpg"
    Const MyPicture = "HEADER.jpg"

    With oMail
      .Subject = "WW OEM Weekly Update " & Date - 7 & " - " & Date
      .To = "some email@email.com"
      .Attachments.Add "C:\Users\Jalexan1\Pictures\HEADER.jpg"
        .HTMLBody = RangetoHTML(rng) & "<html>" & "<img src=cid:" & Replace(MyPicture, " ", "%20") & " height=200 width=980>" "</html>"



      '.Body = "WW OEM PPM WEEKELY UPDATE" & Date
    .Display


   End With

End If





Set oMail = Nothing
Set oLook = Nothing

End Sub

Function RangetoHTML(rng As Range)
    Dim rowcout As Long
    'rowcout = Cells(Rows.Count, "A").End(xlUp).Row'
    Dim sh As Worksheet
    Dim rn As Range
    Set sh = ThisWorkbook.Sheets("Sheet1")
    Dim LastRow As Long
    Set rn = sh.UsedRange
    LastRow = rn.Rows.Count + rn.Row - 1
    Dim startdate As Date, enddate As Date
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
     Dim c As Range

     startdate = CDate(InputBox("Enter a Start Date in the format of MM/DD/YYY : "))
    enddate = CDate(InputBox("End Date: "))
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'copy the range and create a new workbook to paste the data into'
     'LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row

    rng.Copy
    Set TempWB = Workbooks.Add(1)
   For i = 2 To LastRow
    Dim cellcheck As Date
        datecheck = Range("A" & i).Value
        If datecheck >= startdate & datecheck <= enddate Then

        Set TempWB = Workbooks.Add(1)
        rng = Range(("A" & i)).Value
        MsgBox (rangerange)
        rng.Copy
            With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            Cells(1).Select
            Application.CutCopyMode = False
            '.DrawingObjects.Visible = True
            '.DrawingObjects.Delete
           ' On Error GoTo 0
        End With
        End If
        Exit For
        Next i


    '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

 Set fso = CreateObject("Scripting.FileSystemObject")
 Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
 RangetoHTML = ts.ReadAll
 ts.Close
 RangetoHTML = Replace(RangetoHTML, "align=center x:publishsources=", _
                        "slign=left x:publishsource=")
    'close temp wb'
    TempWB.Close savechanges = False

    'Delete the temp file'
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

Answer 1

问题在于您正在查看不存在的单元格“A2104856”而不是单元格“A1048576”。（显然这取决于你使用的是哪个版本的excel，但无论哪种方式，它都会查看超出最大可能行的单元格）

试试这个：

 LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row

并从“A2”中删除“2”＆amp; Rows.Count

＆符号表示将字符串连接到前一个字符串的末尾，而不是向下移动到列的末尾，因此“A2”＆amp; “15”=“A215”

编辑：这似乎解决了原始问题，但是您在评论中提到了另一个问题。

我发现这行中有拼写错误：

 RangetoHTML = Replace(RangetoHTML, "align=center x:publishsources=", _
                    "slign=left x:publishsource=")

“align”拼写错误“slign”。

将此更新为：

 RangetoHTML = Replace(RangetoHTML, "align=center x:publishsources=", _
                    "align=left x:publishsource=")

但是，作为一般建议，如果某些东西没有给你你想要的输出（即使没有抛出错误），最好的第一步是逐步完成代码并验证代码中的每一步正在做你想做的事。

我不确定这是唯一的问题，我不确定它是否会创建一个空白的电子邮件（我似乎更有可能创建一个奇怪的格式，但我没有'测试它），但如果你单步执行此功能，你将能够看到它出错的地方。

使用VBA

1 个答案: