Set range only up until blank row in a particular column

[seaottr]

Hi All,

"Leith" has been phenomenally helpful in helping me out with the bulk of this report I'm trying to figure out. He's basically re-written my code in order to send an e-mail with a particular range in the body of the email.

There's one more thing I'm trying to figure out and that's how to only select the rows up until the first blank cell in column A.

Below is the code that he provided and I've attached an example spreadsheet. In the spreadsheet I want to send range A1:L24 (because L25 has the first blank cell beginning at A4). All the e-mail code works, I just need help figuring out how to send this particular range. The entries are dynamic, so it won't always be up until row 24...it needs to be only up until the first blank cell in Column A beginning at Row 4:

'Written: September 22, 2008
'Updated: August 18, 2011
'Author:  Leith Ross
'Summary: Send a specfied worksheet range in the body of an Outlook email
'         in HTML format.


Sub EmailRangeInHTML(ByVal Recipient As String, ByVal Subject As String, Optional Range_To_Send As Variant)

  Dim FSO As Object
  Dim HTMLcode As String
  Dim HTMLfile As Object
  Dim MyApp As Boolean
  Dim olApp As Object
  Dim Rng As Range
  Dim TempFile As String
  Dim Wks As Worksheet

  Const ForReading As Long = 1
  Const olMailItem = 0
  Const olFormatHTML = 2
  Const UseDefault As Long = -2
    
     On Error GoTo CleanUp
     
     If IsMissing(Range_To_Send) Then
        Set Rng = Selection
     Else
        Select Case TypeName(Range_To_Send)
          Case Is = "Range"
              Set Rng = Range_To_Send
          Case Is = "String"
              Set Rng = Evaluate(Range_To_Send)
          Case Else
              MsgBox "Your Selection is Not a Valid Range."
              GoTo CleanUp
        End Select
     End If
     
     ' Copy the worksheet to create a new workbook
       Set Wks = Rng.Parent
       Wks.Copy
     
     ' The new workbook will be saved to the user's Temp directoy
       TempFile = Environ("Temp") & "\" & Wks.Name & ".htm"
     
     ' If a file by this exists then delete it
       If Dir(TempFile) <> "" Then Kill TempFile
     
         ' Start Outlook
           Set olApp = CreateObject("Outlook.Application")
      
         ' Convert the Message worksheet into HTML
           With ActiveWorkbook.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=Wks.Name, _
             Source:=Rng.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
           End With
       
         ' Read the HTML file back as a string
           Set FSO = CreateObject("Scripting.FileSystemObject")
           Set HTMLfile = FSO.OpenTextFile(TempFile, ForReading, True, UseDefault)
           
            ' Read in the entire file as a string
              HTMLcode = HTMLfile.ReadAll
             
           HTMLfile.Close
          
          
         ' Re-align the HTML code to the left side of the page
           HTMLcode = Replace(HTMLcode, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
                      
         ' Compose and send the email
           Set olEmail = olApp.CreateItem(olMailItem)
             With olEmail
               .To = Recipient
               .Subject = Subject
               .BodyFormat = olFormatHTML
               .HTMLBody = HTMLcode
               .Display
             End With
            
   ' Exit Outlook
   '  olApp.Quit
            
CleanUp:
   ' Did an error occur
     If Err <> 0 Then
        MsgBox "Run-time error '" & Err.Number & "':" & vbCrLf & vbCrLf & Err.Description
     End If
   
   ' Close the new workbook and don't save it
     ActiveWorkbook.Close SaveChanges:=False
  
   ' Delete the Temp File
     If Dir(TempFile) <> "" Then Kill TempFile
   
   ' Delete the Publish Object
     With ActiveWorkbook.PublishObjects
       If .Count <> 0 Then .Item(.Count).Delete
     End With
   
   ' Free memory resources
     Set olApp = Nothing
     Set olEmail = Nothing
     Set FSO = Nothing

End Sub


Private Sub CommandButton2_Click()
' Working in Office 2000-2007
  EmailRangeInHTML "email@email.com", "Team Results - Month-To-Date", Worksheets("Results").Range("A1:L31")
End Sub

Any help would be greatly appreciated!

[Leith Ross]

Hello seaottr,

This will size the emaqil range based on the entries in column "A".

Private Sub CommandButton2_Click()
' Working in Office 2000-2007
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Results")

    Set Rng = Wks.Range("A4")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)

    EmailRangeInHTML "email@email.com", "Team Results - Month-To-Date", Rng.Resize(ColumnSize:=12)
End Sub

[seaottr]

Thanks again Leith, but I'm actually trying to find the Row number of the last blank cell in the Range A4:A30. Maybe it's because there's a formula in those cells that it doesn't register as being "blank".

If you try your code in the attachment that I posted, it doesn't send A1:J24, it sends A1:J31.

The "blank" cells in Range A1:A30 have formulas in them (A25:A30), but no actual values, therefore I don't want to include them in the e-mail.

Let me know if there's any way to do this.

Thanks in advance!

Hello seaottr,

This will size the emaqil range based on the entries in column "A".

Private Sub CommandButton2_Click()
' Working in Office 2000-2007
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Results")

    Set Rng = Wks.Range("A4")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)

    EmailRangeInHTML "email@email.com", "Team Results - Month-To-Date", Rng.Resize(ColumnSize:=12)
End Sub

[Leith Ross]

Hello seaottr,

I forgot about the formulas in column "A". The only reliable way is to check each cell's value using a loop. Here is the working code for the CommandButton2.

Private Sub CommandButton2_Click()
' Working in Office 2000-2007
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
      Set Wks = Worksheets("Results")
      
      Set Rng = Wks.Range("A4")
      Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
      If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd).Resize(ColumnSize:=10)
      
      For R = 1 To Rng.Rows.Count
          If Rng.Item(R, 1) = "" And R <> 1 Then
             Set Rng = Rng.Resize(R - 1, 10)
             Exit For
          End If
      Next R
      
      EmailRangeInHTML "email@email.com", "Team Results - Month-To-Date", Rng
      
End Sub

[seaottr]

Awesome! Thanks buddy!

LAST request (I promise)!!! LOL!

The bottom border is missing from the table in the email body (the range that's being sent). How do I get it to show up?

Thanks again for all your help!

Hello seaottr,

I forgot about the formulas in column "A". The only reliable way is to check each cell's value using a loop. Here is the working code for the CommandButton2.

Private Sub CommandButton2_Click()
' Working in Office 2000-2007
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
      Set Wks = Worksheets("Results")
      
      Set Rng = Wks.Range("A4")
      Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
      If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd).Resize(ColumnSize:=10)
      
      For R = 1 To Rng.Rows.Count
          If Rng.Item(R, 1) = "" And R <> 1 Then
             Set Rng = Rng.Resize(R - 1, 10)
             Exit For
          End If
      Next R
      
      EmailRangeInHTML "email@email.com", "Team Results - Month-To-Date", Rng
      
End Sub

[Leith Ross]

Hello seaotter,

I noticed that also. Unfortunately, I have idea why it isn't showing up. I even tried including a blank row. While this displays the top border for the last entry, the blank row's bottom border is still missing.