Double Loop Through Columns
Option Explicit
Sub PopulateAnD()
' Accounts
Const aName As String = "Accounts"
Const aFirst As String = "A2"
' Departments
Const dName As String = "Departments"
Const dFirst As String = "B2"
' Accounts and Departments
Const adName As String = "Account and Dpt"
Const adFirst As String = "A2"
Const adClearBelow As Boolean = True
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Accounts
Dim aws As Worksheet: Set aws = wb.Worksheets(aName)
Dim afCell As Range: Set afCell = aws.Range(aFirst)
Dim arg As Range: Set arg = RefColumn(afCell)
If arg Is Nothing Then Exit Sub
Dim arCount As Long: arCount = arg.Rows.Count
Dim aData As Variant: aData = GetRange(arg)
' Departments
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
Dim drg As Range: Set drg = RefColumn(dfCell)
If drg Is Nothing Then Exit Sub
Dim drCount As Long: drCount = drg.Rows.Count
Dim dData As Variant: dData = GetRange(drg)
' Accounts and Departments
' Define the array.
Dim adrCount As Long: adrCount = arCount * drCount
Dim adData As Variant: ReDim adData(1 To adrCount, 1 To 2)
' Write to the array.
Dim ar As Long
Dim dr As Long
Dim adr As Long
For dr = 1 To drCount
For ar = 1 To arCount
adr = adr + 1
adData(adr, 1) = aData(ar, 1)
adData(adr, 2) = dData(dr, 1)
Next ar
Next dr
' Write to the range.
Dim adws As Worksheet: Set adws = wb.Worksheets(adName)
Dim adfCell As Range: Set adfCell = adws.Range(adFirst)
WriteData adfCell, adData, adClearBelow
'wb.Save
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') through the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count + rg.Columns.Count = 2 Then ' only one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the values from a 2D array ('Data') to a range
' defined by its first cell ('FirstCell') and by the size
' of the array. Optionally (by default), clears the cells
' below the resulting range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub WriteData( _
ByVal FirstCell As Range, _
ByVal Data As Variant, _
Optional ByVal doClearBelow As Boolean = True)
If FirstCell Is Nothing Then Exit Sub
On Error GoTo ClearError ' if not a 2D array
Dim rCount As Long: rCount = UBound(Data, 1) - LBound(Data, 1) + 1
Dim cCount As Long: cCount = UBound(Data, 2) - LBound(Data, 2) + 1
With FirstCell.Cells(1)
Dim wsrCount As Long: wsrCount = .Worksheet.Rows.Count
Dim wscCount As Long: wscCount = .Worksheet.Columns.Count
If rCount > wsrCount - .Row + 1 Then Exit Sub
If cCount > wscCount - .Column + 1 Then Exit Sub
.Resize(rCount, cCount).Value = Data
If doClearBelow Then
.Resize(wsrCount - .Row - rCount + 1, cCount).Offset(rCount).Clear
End If
End With
ProcExit:
Exit Sub
ClearError:
Resume ProcExit
End Sub
