Range of cells between two merged cells VBA

Question

I have cells D11 through H11 merged, D20 through H20 merged, and D25 through H25 merged. We will call the merged rows sections. So D11 through H11 is section 1, D20 through H20 is section 2, etc. The number of rows between the merged sections can vary.

I'm trying to create a vba that can create the vertical range of the cells between sections. So for example, the vertical range between section 1 and 2 would H12 to H19, and the range between section 2 and 3 would be H21 to H24.

Any ideas?

I'm currently trying create an array with 1s and 2s (2s mean there is a merged cell) and then counting the 1s to try to create a range. I don't know if this will work or if there is an easier way to do this.

Sub newGroup()
Dim LastRow As Integer
Dim i As Long
Dim arr()     'This is an array definition
    i = 0
LastRow = Cells(Rows.Count, "H").End(xlUp).Row


For i = 12 To LastRow + 1
If Cells(i, 8).MergeCells = True Then

ReDim Preserve arr(1 To i)
arr(i) = 2
Else: arr(i) = 1

End If

Next


End Sub

Answer 1

You could have a function that returns an array of unmerged values in a range.

if you can rely on the columns to be the same then do this:

1. loop through a worksheet's rows checking each row's merged value on column 8(H).
2. test each row's .mergecells value for true or false.
3. find the first merged cell value of true.
4. from that point find the next false value, log it as the first row in the unmerge range.
5. find the next merged value, log the previous row as the last unmerge row.

Voila you have your first range. if you want to do this for all of the values have it store them to an array.

Kinda like this:

( I felt guilty about the sloppy code in my initial post so I made a condensed version that should be easier to understand and implement )

Sub Test()
    Dim v() As Variant
    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)           ' assign worksheet you want to scan

    v = Get_Unmerged_Ranges(8, ws)  ' Better version
End Sub

Function Get_Unmerged_Ranges(c As Integer, ws As Worksheet) As Variant
    Dim v() As Variant
    Dim r As Long

    ReDim v(1 To 1)

    With ws
        Do
            r = r + 1
            If .Cells(r, c).MergeCells Then
                If Not IsEmpty(v(1)) Then ReDim Preserve v(1 To UBound(v) + 1)
                i = UBound(v)
                If i Mod 2 = 1 Then
                    v(i) = r + 1 ' Odd entry is counted as start range which is 1 after the mergecells
                Else
                    v(i) = r - 1 ' Even entry is counted as end range which is the 1 before the mergecells
                    r = r - 1 ' Set the row back one to set the first variable on the next loop
                End If
            End If
        Loop Until r > .UsedRange.Rows.Count
    End With
    Get_Unmerged_Ranges = v
End Function

Answer 2

As an alternative using the Range.Find method which is much faster than looping cell by cell. It gathers the sections and puts them into the variable rngSections. Then you can go through them using the rngSections.Areas property (example shown in the code)

Sub tgr()

    Dim rngFound As Range
    Dim rngMerge As Range
    Dim rngSections As Range
    Dim SectionArea As Range
    Dim strFirst As String

    With Application.FindFormat
        .Clear
        .MergeCells = True
    End With

    Set rngFound = Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchFormat:=True)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Set rngMerge = rngFound
        Do
            Set rngFound = Cells.Find("*", rngFound, SearchFormat:=True)
            If rngFound.Address = strFirst Then Exit Do
            If rngFound.Row - rngMerge.Row > 1 Then
                Select Case (rngSections Is Nothing)
                    Case True:  Set rngSections = Range(rngMerge.Offset(1), rngFound.Offset(-1))
                    Case Else:  Set rngSections = Union(rngSections, Range(rngMerge.Offset(1), rngFound.Offset(-1)))
                End Select
            End If
            Set rngMerge = rngFound
        Loop
    End If

    If Not rngSections Is Nothing Then
        'Whatever you want to do with the sections
        'For example, you could loop through them
        For Each SectionArea In rngSections.Areas
            MsgBox SectionArea.Address
        Next SectionArea
    End If

End Sub

Answer 3

You might want to try looping down the column, and adding each new non-merged cell to your range, like:

Set r1 = Nothing
Do Until Cells(row, 8).MergeCells = True
    If r1 Is Nothing Then
        Set r1 = Range(Cells(row, 8), Cells(row, 8))
    Else
        Set r1 = Union(r1, Range(Cells(row, 8), Cells(row, 8)))
    End If
row = row + 1
Loop

Then providing as many range variables as you have sections.