Loop through each cell in range vertically - excel

Question

I have a loop that goes through two-dimensional range
set rng = Range("A1:C3")
For each cell in rng
Debug.Print cell.value
next cell
It prints like:
A1
B1
C1
A2
B2...
I would prefer:
A1
A2
A3
B1
B2...
I know there is a way to do that looping with indexes but for each is much more elegant and on the top of that my range can be non-contiguous like:
Range("A1:C3,G9:H16,B14:D18")
Is there a way how to change default (horizontal) excel behavior?

Answer 1

Loop Through the Cells of a Non-Contiguous Range (Multi-Range)
By Areas
The numbers in the yellow cells in the image are illustrating the looping order by areas and by rows. The results of the procedures in the J and K columns are copied from the Immediate window and are showing both of the looping orders.
Option Explicit
Sub WriteCellsByAreaRows()
Const sAddress As String = "A1:C3,G9:H16,B14:D18"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim mrg As Range: Set mrg = ws.Range(sAddress)
Dim arg As Range
Dim aCell As Range
For Each arg In mrg.Areas
For Each aCell In arg.Cells
Debug.Print aCell.Address(0, 0) & " = " & aCell.Value
Next aCell
Next arg
End Sub
Sub WriteCellsByAreaColumns()
Const sAddress As String = "A1:C3,G9:H16,B14:D18"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim mrg As Range: Set mrg = ws.Range(sAddress)
Dim arg As Range
Dim acrg As Range
Dim aCell As Range
For Each arg In mrg.Areas
For Each acrg In arg.Columns
For Each aCell In acrg.Cells
Debug.Print aCell.Address(0, 0) & " = " & aCell.Value
Next aCell
Next acrg
Next arg
End Sub
EDIT
Area Independent (The Challenge)
The numbers in the yellow cells in the image are illustrating the looping order by rows. The results of the procedures in the J and K columns are copied from the Immediate window and are showing both of the looping orders.
Short Function Description (By Columns)
It will loop through the columns of each area and write the column number to an Array List which will finally be sorted. When looping through the elements of the Array List (each column number), a reference to the intersection of the worksheet column and the initial multi-range will be created and each single range reference will be written to an array. The array will be (bubble) sorted by the row numbers of every single column range and then will be added as an element of the resulting array of arrays.
Sub WriteCellsByColumn()
Const sAddress As String = "A1:C3,G9:H16,B14:D18"
Dim ws As Worksheet: Set ws = ActiveSheet
On Error Resume Next
Dim mrg As Range: Set mrg = ws.Range(sAddress)
On Error GoTo 0
If mrg Is Nothing Then Exit Sub
Dim ColumnRanges As Variant: ColumnRanges = GetSortedColumnRanges(mrg)
If IsEmpty(ColumnRanges) Then Exit Sub ' e.g. 'ArrayList' is not working
Dim cCell As Range
Dim a As Long
Dim b As Long
For a = 0 To UBound(ColumnRanges)
For b = 0 To UBound(ColumnRanges(a))
For Each cCell In ColumnRanges(a)(b).Cells
Debug.Print cCell.Address(0, 0) & " = " & cCell.Value
Next cCell
Next b
Next a
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the sorted column range references of a range ('mrg')
' in an array of arrays.
' Remarks: Supports non-contiguous ranges (multi-ranges).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetSortedColumnRanges( _
ByVal mrg As Range) _
As Variant
If mrg Is Nothing Then Exit Function
On Error Resume Next ' The ArrayList needs 'Microsoft .NET Framework 3.5'.
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
On Error GoTo 0
If arl Is Nothing Then Exit Function
Dim arg As Range ' Area (Single) Range
Dim crg As Range ' Column Range (in Area Range)
Dim cColumn As Long ' Column Number (of Column Range)
For Each arg In mrg.Areas
For Each crg In arg.Columns
cColumn = crg.Column
If Not arl.Contains(cColumn) Then
arl.Add cColumn
End If
Next crg
Next arg
arl.Sort
' Create a reference to the worksheet ('ws').
Dim ws As Worksheet: Set ws = mrg.Worksheet
' Define the Multi Range Array ('mrgArr').
Dim mrgArr As Variant: ReDim mrgArr(0 To arl.Count - 1)
Dim icrg As Range ' Intersect Column Range (in Worksheet Column)
Dim trg As Range ' Temp Range
Dim trgArr() As Range ' Temp Range Array
Dim Key As Variant '
Dim aUpper As Long
Dim a As Long
Dim b As Long
Dim n As Long
For Each Key In arl
Set icrg = Intersect(mrg, ws.Columns(Key))
aUpper = icrg.Areas.Count - 1
If aUpper = 0 Then
' Write current Intersect Row Range reference to Temp Range Array.
ReDim trgArr(0 To 0): Set trgArr(0) = icrg
Else
' Write current Intersect Row Range references to Temp Range Array.
ReDim trgArr(0 To aUpper)
For a = 0 To aUpper
Set trgArr(a) = icrg.Areas(a + 1)
Next a
' (Bubble) Sort the references by rows.
For a = 0 To aUpper - 1
For b = a To aUpper
If trgArr(a).Row > trgArr(b).Row Then
Set trg = trgArr(a)
Set trgArr(a) = trgArr(b)
Set trgArr(b) = trg
End If
Next b
Next a
End If
' Write the current Temp Range Array to the current element
' of the Multi Range Array.
mrgArr(n) = trgArr
n = n + 1
Next Key
GetSortedColumnRanges = mrgArr
End Function
Sub WriteCellsByRow()
Const sAddress As String = "A1:C3,G9:H16,B14:D18"
Dim ws As Worksheet: Set ws = ActiveSheet
On Error Resume Next
Dim mrg As Range: Set mrg = ws.Range(sAddress)
On Error GoTo 0
If mrg Is Nothing Then Exit Sub
Dim RowRanges As Variant: RowRanges = GetSortedRowRanges(mrg)
If IsEmpty(RowRanges) Then Exit Sub ' e.g. 'ArrayList' is not working
Dim rCell As Range
Dim a As Long
Dim b As Long
For a = 0 To UBound(RowRanges)
For b = 0 To UBound(RowRanges(a))
For Each rCell In RowRanges(a)(b).Cells
Debug.Print rCell.Address(0, 0) & " = " & rCell.Value
Next rCell
Next b
Next a
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the sorted row range references of a range ('mrg')
' in an array of arrays.
' Remarks: Supports non-contiguous ranges (multi-ranges).
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetSortedRowRanges( _
ByVal mrg As Range) _
As Variant
If mrg Is Nothing Then Exit Function
On Error Resume Next ' The ArrayList needs 'Microsoft .NET Framework 3.5'.
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
On Error GoTo 0
If arl Is Nothing Then Exit Function
Dim arg As Range ' Area (Single) Range
Dim rrg As Range ' Row Range (in Area Range)
Dim cRow As Long ' Row Number (of Row Range)
For Each arg In mrg.Areas
For Each rrg In arg.Rows
cRow = rrg.Row
If Not arl.Contains(cRow) Then
arl.Add cRow
End If
Next rrg
Next arg
arl.Sort
' Create a reference to the worksheet ('ws').
Dim ws As Worksheet: Set ws = mrg.Worksheet
' Define the Multi Range Array ('mrgArr').
Dim mrgArr As Variant: ReDim mrgArr(0 To arl.Count - 1)
Dim irrg As Range ' Intersect Row Range (in Worksheet Row)
Dim trg As Range ' Temp Range
Dim trgArr() As Range ' Temp Range Array
Dim Key As Variant '
Dim aUpper As Long
Dim a As Long
Dim b As Long
Dim n As Long
For Each Key In arl
Set irrg = Intersect(mrg, ws.Rows(Key))
aUpper = irrg.Areas.Count - 1
If aUpper = 0 Then
' Write current Intersect Row Range reference to Temp Range Array.
ReDim trgArr(0 To 0): Set trgArr(0) = irrg
Else
' Write current Intersect Row Range references to Temp Range Array.
ReDim trgArr(0 To aUpper)
For a = 0 To aUpper
Set trgArr(a) = irrg.Areas(a + 1)
Next a
' (Bubble) Sort the references by rows.
For a = 0 To aUpper - 1
For b = a To aUpper
If trgArr(a).Column > trgArr(b).Column Then
Set trg = trgArr(a)
Set trgArr(a) = trgArr(b)
Set trgArr(b) = trg
End If
Next b
Next a
End If
' Write the current Temp Range Array to the current element
' of the Multi Range Array.
mrgArr(n) = trgArr
n = n + 1
Next Key
GetSortedRowRanges = mrgArr
End Function

Answer 2

Maybe
Sub Test()
Dim rng As Range, rRow As Range, rCol As Range
Set rng = Range("A1:C3")
For Each rCol In rng.Columns
For Each rRow In rCol.Cells
Debug.Print rRow.Value
Next rRow
Next rCol
End Sub

Answer 3

As a proof-of-concept with non-contiguous ranges that may overlap. Determine the lowest row and right most column of the areas, create a array that encloses all those areas, and fill it with the cell addresses of the cells in each area. Then traverse the array horizontally or vertically skipping over the blank entries.
Option Explicit
Sub demo_by_column()
Dim ar, a, cell As Range, rng As Range, i As Long
Dim rmax As Long, cmax As Long, rmin As Long, cmin As Long
Dim r As Long, c As Long
rmin = Rows.Count
cmin = Columns.Count
' non-contiguous range
Set rng = Sheet1.Range("A1:C3,D9:H16,B14:D18,A21:J21")
' dimension an array that encloses all the areas
For Each a In rng.Areas
r = a.Row + a.Rows.Count - 1
If r > rmax Then rmax = r
If a.Row < rmin Then rmin = a.Row
c = a.Column + a.Columns.Count - 1
If c > cmax Then cmax = c
If a.Column < cmin Then cmin = a.Column
Next
ReDim ar(1 To rmax, 1 To cmax)
' fill array with cell addresses
For Each a In rng.Areas
For Each cell In a
ar(cell.Row, cell.Column) = cell.Address
Next
Next
' loop the array by column, result to sheet2
i = 1
For c = cmin To cmax
For r = rmin To rmax
If Len(ar(r, c)) > 0 Then
Sheet2.Cells(i, 1) = Sheet1.Range(ar(r, c))
i = i + 1
End If
Next
Next
' show array on sheet3
Sheet3.Range("A1").Resize(rmax, cmax) = ar
End Sub