Unintended SpecialCells count result in non-contiguous range

[CtrlAltDel2X]

Excel 2010

I'm trying to ensure there's a blank row between ranges on a worksheet by creating a non-contiguous range derived from a column on the worksheet known to have data and looping through the non-contiguous range. As soon as I hit a range that is only one row the SpecialCells count produces an unintended result.

To assist those kind enough to help below is Sub SetupSheet() which will set up a worksheet with the layout and data types I'm working with. The rest of the code is what I'm working with.

What I'm trying to do: Ensure the first column of each range contains only one cell with text in it.

As it's written the function Check_TextHdr2_Ranges will result in 30 when it iterates through the last range, i.e. $B$13. If I add anything in D14:J14 it returns what I expect, a 1. If make any of the other "ranges" only 1 row it will generate an unintended result on that "range".

Option Explicit

Many thanks for taking a look.


Sub Check_Ranges()
Dim ws As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim Header_Row As Range
Dim HeaderTitle As String
Dim TextHdr2Addr As Range
Dim TextHdr2Rng As Range
Dim ThisCellInTextHdr2Rng As Range




Set ws = Worksheets("Sheet1")
ws.Activate


LastColumn = ws.Cells(1, 1).CurrentRegion.Columns.Count
LastRow = ws.Cells(Rows.Count, "D").End(xlUp).Row
Set Header_Row = Range(ws.Cells(1, 1), ws.Cells(1, LastColumn))


'Uses the HeaderAddress Function to identify various column locations based on the text in the Header_Row.  In this case, Text Header 2.
HeaderTitle = "Text Header 2"
Set TextHdr2Addr = HeaderAddress(Header_Row, HeaderTitle)


'Create a non-contiguous range of the specialcells in column B that have text in them
Set TextHdr2Rng = ws.Range(TextHdr2Addr.Offset(2, 0), Cells(LastRow, TextHdr2Addr.Column)).SpecialCells(xlCellTypeConstants, xlTextValues)




'Check each section to make sure they're separated by an empty row
If Check_TextHdr2_Ranges(ws, LastColumn, TextHdr2Rng, ThisCellInTextHdr2Rng) <> 1 Then
    MsgBox "WARNING: It appears you have sections NOT separated by an empty row." _
    & vbNewLine & vbNewLine & "Please insert a blank row to delinate between the sections."
End If


End Sub


Private Function Check_TextHdr2_Ranges(ws As Worksheet, LastColumn As Long, TextHdr2Rng As Range, ThisCellInTextHdr2Rng As Range) As Integer
Dim LastRowOfSection As Long
Dim ThisSectionRng As Range


For Each ThisCellInTextHdr2Rng In TextHdr2Rng
    With ThisCellInTextHdr2Rng.CurrentRegion
        LastRowOfSection = .Rows(.Rows.Count).Row
    End With
       
    Set ThisSectionRng = ws.Range(ThisCellInTextHdr2Rng, Cells(LastRowOfSection, LastColumn))
    Debug.Print ThisSectionRng.Columns(1).SpecialCells(xlCellTypeConstants, 2).Count
    Debug.Print
    If ThisSectionRng.Columns(1).SpecialCells(xlCellTypeConstants, 2).Count <> 1 Then
        Check_TextHdr2_Ranges = ThisSectionRng.Columns(1).SpecialCells(xlCellTypeConstants, 2).Count
        Application.Goto ThisCellInTextHdr2Rng.Offset(0, -1), True
        Exit Function
    End If
        
Next ThisCellInTextHdr2Rng
Check_TextHdr2_Ranges = ThisSectionRng.Columns(1).SpecialCells(xlCellTypeConstants, 2).Count


End Function


Private Function HeaderAddress(Header_Row As Range, HeaderTitle As String) As Range
    Set HeaderAddress = Range(Header_Row.Find(What:=HeaderTitle, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Address)
End Function
'This is just to setup the worksheet as I have it for those kind enough to help
Sub SetupSheet()
Dim textstuff As String
Dim numberstuff As Long
Dim textANDnumberstuff As String
Dim rng As Range
Dim headerstr As String
Dim i As Long


headerstr = "Text Header"
For i = 1 To 10
Cells(1, i).Value = headerstr & " " & i
Next i


textstuff = "Text Here"
Range("A3, A6, A10, A13").Value = textstuff


textANDnumberstuff = "Text And 1"
Range("B3, B6, B10, B13").Value = textstuff


Set rng = Range("C3, C6, C10, C13")


For Each rng In rng
    With rng
        .Hyperlinks.Add Anchor:=rng, Address:="mailto:abc@def_.com", TextToDisplay:="abc@def_.com"
    End With
Next rng


Range("D3, D4, D6, D7, D8, D10, D11, D13").Value = textstuff


numberstuff = 12345
Range("E3, E4, E6, E7, E10, E11, E13").Value = numberstuff
Range("F3, F4, F8, F10, F11, F13").Value = numberstuff
Range("G4, G6, G7, G11, G13").Value = numberstuff
Range("H3, H4, H8, H13").Value = numberstuff


Columns.AutoFit


End Sub