excel 将非连续范围从并集传入Outlook的问题

一群老师（我就是其中之一）正在使用电子表格来跟踪学生未完成的作业。学生的名字在A列，未完成的作业在右侧的列中展开。当某位老师的作业丢失时，老师会在单元格中输入他们的姓名首字母，然后右键单击以添加有关该作业的注解。当学生最终提交作业时，教师将单元格的填充从空（xlNone）更改为黄色或灰色。我们希望Excel每天向我们发送一封电子邮件，其中只列出在单元格中缺少作业的学生，这些单元格用xlNone填充，并带有教师姓名的首字母。
下面的代码没有错误，但也不起作用。电子邮件对象已构造，但邮件正文中没有数据。如有任何帮助，将不胜感激。谢谢。

Sub Mail_Selection_Range_Outlook_Body()
'Thanks to code by Tim Williams and Ron de Bruin

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    On Error Resume Next
    Dim cell As Range
    Dim ci As Long
    Set rng = Nothing
    
    For Each cell In Sheet1.Range("C4:Z100").Cells
        ci = cell.Interior.ColorIndex
        If (ci = -4142 Or ci = 2 Or ci = 15 Or ci = 16) And Not IsNumeric(cell.Value) Then
            If rng Is Nothing Then
                Set rng = cell
            Else
                Set rng = Application.Union(rng, cell)
            End If
        End If
    Next cell
    
    If Not rng Is Nothing Then rng.Select
        
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "teacher1@school.org, teacher2@school.org"
        .CC = ""
        .BCC = ""
        .Subject = "This is the list of students with missing work"
        .HTMLBody = RangetoHTML(rng)
        .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
' Thanks to Ron de Bruin's page
    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 paste 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 Mail_Selection_Range_Outlook_Body()
'Thanks to code by Tim Williams and Ron de Bruin

'    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
'    On Error Resume Next
    Dim cell As Range
    Dim ci As Long
'    Set rng = Nothing
    Dim str As String
    str = Empty
    
    For Each cell In Sheet1.Range("C4:Z100").Cells
        ci = cell.Interior.ColorIndex
        If (ci = -4142 Or ci = 2 Or ci = 15 Or ci = 16) And Not IsNumeric(cell.value) Then
        '****************************************************************************
'            If rng Is Nothing Then
'                Set rng = cell
'            Else
'                Set rng = Application.Union(rng, cell)
'            End If
            str = str & CStr(cell.value) & " "
        '****************************************************************************
        End If
    Next cell
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
'    On Error Resume Next
    With OutMail
        .To = "teacher1@school.org, teacher2@school.org"
        .CC = ""
        .BCC = ""
        .Subject = "This is the list of students with missing work"
        
        '****************************************************************************
        Dim wdDoc As Object
        Dim olinsp As Object
        
        Set wdDoc = CreateObject("Word.Document")
        Set olinsp = .GetInspector
        Set wdDoc = olinsp.WordEditor
        
        If Not IsEmpty(str) Then
            wdDoc.Range.InsertBefore str
            .Display
            .Send
        Else
            MsgBox prompt:="No cells meet the criteria"
            Exit Sub
        End If
        '****************************************************************************
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Set wdDoc = Nothing
    Set olinsp = Nothing
    
End Sub

因此，我不确定这是否能达到预期的结果，但是在使用测试工作表进行测试后，我成功地显示了电子邮件，其中所有相关单元格值都由空格分隔（您可以选择任何分隔值的方式，只需替换包含str = str & CStr(cell.value) & " "的行上的““即可。
我更改了.Send方法在代码中的位置，这样如果没有相关的单元格，就不会发送电子邮件。
我不明白你怎么知道哪个学生还没有交作业，因为相关的单元格只包含老师的首字母？还是我搞错了？
如果您需要在每个单元格值中包含学生的姓名，那么可以很容易地修改代码来实现这一点，但是我不确定我是否完全理解这里所需的输出是什么。
不管怎样，让我知道它的进展。

增加

您可以输出一行，如下所示：studentA_J studentB_F studentC_W，J F和W是教师姓名的首字母。要实现这一点，您只需将包含str = str & CStr(cell.value) & " "的行更改为str = str & Sheet1.Cells(cell.row,j) & "_" & CStr(cell.value) & " "，其中j需要是学生姓名所在列的索引。
如果我没记错的话，你甚至可以用列的字母来写，例如，如果学生的名字在A列，那么你也可以用str = str & Sheet1.Cells(cell.row,"A") & "_" & CStr(cell.value) & " "来替换上面的代码行

升级代码

Sub Mail_Selection_Range_Outlook_Body()
'Thanks to code by Tim Williams and Ron de Bruin

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range, studentCell As Range
    Dim ci As Long
    Dim str As String
    str = Empty
    
    With Application
        .calculation = xlCalculationManual
        .DisplayStatusBar = False
        .enableEvents = False
        .screenUpdating = False
        .Interactive = False
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
    
    For Each cell In Sheet1.Range("C4:Z100").Cells
        ci = cell.Interior.ColorIndex
        If (ci = -4142 Or ci = 2 Or ci = 15 Or ci = 16) And Not IsNumeric(cell.value) Then
        '****************************************************************************
            Set studentCell = Sheet1.Cells(cell.Row, "A")
            
            With cell
                If Not .CommentThreaded Is Nothing Then
                    str = str & studentCell.value & "_" & CStr(.value) & "_" & .CommentThreaded.Text & vbCrLf
                Else
                    str = str & studentCell.value & "_" & CStr(.value) & vbCrLf
                End If
            End With
        '****************************************************************************
        End If
    Next cell
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .To = "teacher1@school.org, teacher2@school.org"
        .CC = ""
        .BCC = ""
        .Subject = "This is the list of students with missing work"
        
        '****************************************************************************
        Dim wdDoc As Object
        Dim olinsp As Object
        
        Set wdDoc = CreateObject("Word.Document")
        Set olinsp = .GetInspector
        Set wdDoc = olinsp.WordEditor
        
        If Not IsEmpty(str) Then
            wdDoc.Range.InsertBefore str
        Else
            MsgBox prompt:="No cells meet the criteria"
            GoTo SafeExit
        End If
        '****************************************************************************
        .Display
        .Send
    End With
    
SafeExit:
    With Application
        .calculation = xlCalculationAutomatic
        .DisplayStatusBar = False
        .enableEvents = False
        .screenUpdating = False
        .Interactive = False
        .DisplayAlerts = False
        .AskToUpdateLinks = False
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Set wdDoc = Nothing
    Set olinsp = Nothing
    
End Sub

如果您使用这个升级的代码，那么它将运行得更快。

excel 将非连续范围从并集传入Outlook的问题

1条答案

相关问题

热门标签

最新问答