Copy table to email error

[2000km12]

Hello, I am attempting to copy part of my excel worksheet as a table to an email. I have a for loop that loops through every row, with "rw" being the variable used for that current row. When I use my code, it is only copying column G and I am unsure why.

Help would be appreciated

'Set the variables for the loop
Dim LastRw As Long, FirstRw As Long
Dim Rw As Long
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)

With ActiveSheet
'Define First and Last Rows
FirstRw = 2
LastRw = sht.UsedRange.Rows(.UsedRange.Rows.Count).Row

'Create loop to go through all rows
For Rw = LastRw To FirstRw Step -1

'If the due date is equal to today, run code:
If sht.Range("G" & Rw).Value = Date Then
Set rng = sht.Range("A:G" & Rw).SpecialCells(xlCellTypeVisible)

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

With OutMail
.Subject = "Reminder - CAR(s) Due Today"
.To = sht.Range("B" & Rw).Value
.CC = "Anna Passaro"

.HTMLBody = RangetoHTML(rng) & "Good Morning," & "<br>" & "<br>" & "This is a friendly reminder that you have a Corrective Action" & "<b>" _
& " due today." & "</b>" & " Please let me or Anna Passaro know if you require any additional support. " & "<br>" & "<br>" _
& "<u>" & "Please note, an extension cannot be requested as we are past the extension request due date. This action must be" & _
" completed today to avoid escalation." & "</u>" & "<br>" & "<br>" & "<br>" & "<br>" & "Thank You," & "<br>"

.Display
End With

Set OutApp = Nothing
Set Message = Nothing
End If

 

[Alex Blakenburg]

Your On Error Resume Next is hiding the fact that the line below in invalid.

Set rng = sht.Range("A:G" & Rw).SpecialCells(xlCellTypeVisible)

You need a row number after "A".
eg sht.Range("A2:G" & Rw)

 

[2000km12]

Thank you!!

 

[Alex Blakenburg]

You're welcome.