Share via

Help with macros

Anonymous
2023-07-12T16:50:00+00:00

I wrote the code pasted below (copied and pasted some of it) and it works fine, but I need help to edit it. The spreadsheets copy to the email but there are a lot of empty rows between the top and bottom of the table. The amount of data in the table changes daily so some days there are more empty rows than others.

Here is what I need:

  1. An edited version of this code that scans the data table and gets rid of the empty rows before the table is populated in the email

OR

  1. An edited version of this code that makes the tables dynamic so that only the rows that have data show up and no deleting empty rows is necessary.

I had to edit the code to not reveal any info about my company, so if it looks a little off, that is why.

Here's the code:

Sub ToOutlook()

Dim OutApp As Object
Dim OutMail As Object
Dim rg1 As Range, rg2 As Range
Dim str1 As String, str2 As String
Dim nextBusinessDay As Date
nextBusinessDay = GetNextBusinessDay(Date)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Set rg1 = Sheets("DailyActivity").Range(Cells(1, 1), Cells(17, 7))
Set rg2 = Sheets("DailyActivity").Range(Cells(19, 1), Cells(35, 7))

str1 = "<BODY style = font-size:12pt;font-family:Calibri>" & _
"All, <p> Please see below for the activity scheduled for  " & Format(nextBusinessDay, "dddd, d/m.")

str2 = "<br> Thanks,"

On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = " Activity - " & Format(nextBusinessDay, "d/m")
        .Display
        .HTMLBody = str1 & RangetoHTML(rg1) & RangetoHTML(rg2) & str2 & .HTMLBody
        
    End With
    On Error GoTo 0
    
Set OutMail = Nothing
Set OutApp = Nothing

End Sub

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

Function GetNextBusinessDay(ByVal startDate As Date) As Date
    Dim nextDay As Date
    nextDay = startDate
    
    Do
        nextDay = nextDay + 1 ' Increase the date by one day
        
        ' Check if the next day is a weekend (Saturday or Sunday)
        If Weekday(nextDay, vbMonday) < 6 Then
            ' If it's a weekday, exit the loop and return the next business day
            Exit Do
        End If
    Loop
    
    GetNextBusinessDay = nextDay
End Function
Microsoft 365 and Office | Excel | For business | Windows

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments

4 answers

Sort by: Most helpful
Most helpful Newest Oldest
  1. Anonymous
    2023-07-19T04:28:38+00:00

    Sheets(1).Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    or

    Sheets("DailyActivity").Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Set rg1 = Sheets("DailyActivity").usedrange

    Was this answer helpful?

    0 comments
  2. Anonymous
    2023-07-19T04:21:33+00:00

    https://answers.microsoft.com/en-us/msoffice/forum/all/generate-report-using-vba/a8c58542-d8c8-4dc7-85a3-397e49afcaaf

    this kind of report?

    I am afraid you'd better extract from raw data directly rather than convert excel layout to html table under this scenaria.

    by the way,convert range to html.table ,you can run codes below more quickly than export html temp file by Excel and read all strings from the file again.

    'Following function converts Excel range to HTML table

Public Function ConvertRangeToHTMLTable(rInput As Range) As String

'Declare variables

 Dim rRow As Range

Dim rCell As Range

Dim strReturn As String

'Define table format and font

 strReturn = "<Table border='1' cellspacing='0' cellpadding='7' style='border-

collapse:collapse;border:none'> "

'Loop through each row in the range

For Each rRow In rInput.Rows

 'Start new html row

strReturn = strReturn & " <tr align='Center'; style='height:10.00pt'> "

For Each rCell In rRow.Cells

'If it is row 1 then it is header row that need to be bold

 If rCell.Row = 1 Then

strReturn = strReturn & "<td valign='Center' style='border:solid 

windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'><b>" & rCell.Text & "</b>

</td>"

 Else

 strReturn = strReturn & "<td valign='Center' style='border:solid 

windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'>" & rCell.Text & "</td>" 

 End If

 Next rCell

 'End a row 

strReturn = strReturn & "</tr>"

 Next rRow

 'Close the font tag 

strReturn = strReturn & "</font></table>" 

'Return html format 

ConvertRangeToHTMLTable = strReturn 

End Function

    Was this answer helpful?

    0 comments
  3. Anonymous
    2023-07-18T19:06:48+00:00

    So this is the spreadsheet with the tables the code populates into the email, and the table in the email includes all the rows that don't have data. I need a code that removes those empty rows and keeps the ones with data.

    These exact tables show up in the body of the email just like this. I need the empty rows removed.

    Was this answer helpful?

    0 comments
  4. Anonymous
    2023-07-13T02:36:39+00:00

    gets rid of the empty rows before the table is populated in the email

    Sorry,I can not visualize what you mentioned empty rows ？

    Can you share your original Excel and.show your expected result?

    What's the result you have get now?

    Was this answer helpful?

    0 comments