Send an email with "missing" text range rows VBA

[dacast]

i have a list of missing and file names hyperlinks

I want to create a button that, when clicked, reads the entire column and if it finds "missing," will collect those rows range and then will go to column A and read the first 2 letters and, based on that, will send an email to the corresponding person with the missing rows and header. please see the image for clarification

in this sample:
will read column C will collect rows 78 to 81, and an email will be sent to smith.bbb@compnay.com with only these 4 rows and ABC columns

thank you for your help

 

[mumps]

Delete all the "email" buttons except one and assign the CreateEmails macro to it:

Sub CreateEmails()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, rng1 As Range, rng As Range, ws2 As Worksheet, ws3 As Worksheet, lRow As Long, fnd As Range
    Dim mon As String, rMon As Range, MN As Range
    mon = InputBox("Enter the month name.")
    If mon = "" Then Exit Sub
    Set ws2 = Sheets("General inf")
    Set ws3 = Sheets("MONTHS")
    Set rMon = Rows(5).Find(Left(mon, 3), LookIn:=xlValues, lookat:=xlWhole)
    If Not rMon Is Nothing Then
        Set OutApp = CreateObject("Outlook.Application")
        With ws3
            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Range("A5").CurrentRegion.AutoFilter rMon.Column, "missing"
            Set rng1 = .Range("A6:A" & lRow).SpecialCells(xlCellTypeVisible)
            With CreateObject("scripting.dictionary")
                For Each MN In rng1
                    If Not .exists(Left(MN, 2)) Then
                        .Add Left(MN, 2), Nothing
                        ws3.Range("A5").AutoFilter 1, Criteria1:=Left(MN, 2) & "*"
                        fvisrow = ws3.Range("A6:A" & lRow).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
                        Set fnd = ws2.Range("C4:C7").Find(Left(ws3.Range("A" & fvisrow), 2), LookIn:=xlValues, lookat:=xlWhole)
                        Set rng = Union(ws3.Range("A5:B" & lRow), ws3.Range(ws3.Cells(5, rMon.Column), ws3.Cells(lRow, rMon.Column))).SpecialCells(xlCellTypeVisible)
                        Set OutMail = OutApp.CreateItem(0)
                        With OutMail
                            .to = fnd.Offset(, 4)
                            .cc = fnd.Offset(, 6)
                            .Subject = "Missing maintenance sheets"
                            .HTMLBody = RangetoHTML(rng)
                            .Display
                        End With
                    End If
                Next MN
            End With
        End With
    End If
    ws3.Range("A5").AutoFilter
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    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"
    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
    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:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[dacast]

Amazing! work nicely. thank you very much

 

[mumps]

You are very welcome.