Looping through Adjacent Cells Under a Merged Cell-CodePudding

I am trying to create a VBA code that will let me refer to a header that is merged and go through all the cells that are under the header. Is it possible to create a Do Until Loop that goes through a range of adjacent merged cells?

For example, the header is a merged cell from A1 to C1 and D1 to G1 and I want to create a loop that counts values from different sources under each header. Currently, I have a for loop which goes through the specific column numbers but I am thinking of changing it to a Do Until Loop so when I add a column and include it in the header and re-run the macro, it will include all columns under the header.

'Signals (Ped)
For a = 143 To 148
    For b = 4 To 203
    Worksheets("EACH ITEM CALCS").Cells(b, a).Value = _
        Application.CountIfs(Range(Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(9, 25), Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(5000, 25)), Worksheets("EACH ITEM CALCS").Cells(b, 1), _
        Range(Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(9, 46), Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(5000, 46)), Worksheets("EACH ITEM CALCS").Cells(3, a), _
        Range(Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(9, 44), Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(5000, 44)), "<>X")
Next b
Next a

'Ped Button
For b = 4 To 203
Worksheets("EACH ITEM CALCS").Cells(b, 149).Value = _
    Application.CountIfs(Range(Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(9, 25), Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(5000, 25)), Worksheets("EACH ITEM CALCS").Cells(b, 1), _
    Range(Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(9, 49), Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(5000, 49)), "<>-", _
    Range(Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(9, 48), Worksheets("SIGNAL POLE SCHED WORKSHEET").Cells(5000, 48)), "<>X")
Next b

These are the headers an cells that I want to reference Any help would be appreciated!

CodePudding user response：

I don't know about using Do Until, but if you just need to find the Range of used cells underneath a merged header, you can use Range.MergeArea, which returns the collection of cells that are merged together for the given range. And then EntireColumn to get the full columns of that merged area. Then you just need to trim it down to the non-blank region and cut off the top part where the header is.

Here's an example of how to get this range.

Sub Example()
    Debug.Print UsedAreaUnderMergedHeader(Range("A1:C1")).Address
    Debug.Print UsedAreaUnderMergedHeader(Range("A1")).Address
    'My header is merged "A1:C1"
    'Both lines print the same output
    'Output is "$A$2:$C$28"
End Sub

Function UsedAreaUnderMergedHeader(Header As Range) As Range
    'Finding the Merged Area of the Header
    Dim MergedArea As Range
    Set MergedArea = Header.Cells(1).MergeArea
    
    'Finding the set of columns for that merged area
    Dim WholeColumns As Range
    Set WholeColumns = MergedArea.Columns.EntireColumn
    
    'Find the last row in the set of columns (check each column)
    Dim Column As Range, LastRow As Long
    For Each Column In WholeColumns.Columns
        Dim cLast As Long
        cLast = Column.Cells(Header.Parent.Rows.Count).End(xlUp).Row
        If cLast > LastRow Then LastRow = cLast
    Next
    
    'Build and return the range - The area under the merged header, up till the last row
    Set UsedAreaUnderMergedHeader = Header.Offset(MergedArea.Rows.Count).Resize(LastRow - MergedArea.Row - MergedArea.Rows.Count   1, WholeColumns.Columns.Count)
End Function

Then you can loop through this range like

Dim Cell As Range
For Each Cell In MyRange.Cells
   'do stuff
Next

Or you can loop by rows like

Dim Row As Range
For Each Row in MyRange.Rows
   'do stuff
Next