Loop issue VBA - paste on last row

Question

I am fairly new to VBA and struggling to understand why my macro is not working.

The context: I have an Excel workbook with 3 sheets:

• Sheet"Department" with a list of names
• Sheet"Accounts" with a list of accounts
• Sheet"Departments and Accounts" which is where my output should be

What I am trying to do I want to :

• Copy the list of all the accounts from the Sheet "Accounts" and paste it on the Sheet "Departments and Accounts"in column A
• go to the Sheet "Department", copy the first department name
• go to the sheet "Departments and Acounts" and paste the department name in column B until next to the account
• repeat until all my department have been pasted

Desired output I would have the bloc with all the accounts with one department next to it, and as many blocs as there are departments on the list. On the sheet it would look like this: extract excel

My code so far

Sub Macro1()
'
' Macro1 Macro
'
Dim lrow As Long
Dim i As Integer

lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row


For i = 1 To 47

Sheets("Accounts").Select
Range("A2:A178").Select
Selection.Copy

Sheets("Account and Dpt").Select
Range("A" & lrow + 1).Select
ActiveSheet.Paste

Sheets("Departments").Select '
Range("B" & i + 1).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Account and Dpt").Select
Range("B" & lrow + 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste

i = i + 1

Next i

End Sub

When I run it - nothing happens; can you help me understanding how to fix it ?

Many thanks!!

Answer 1

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

Answer 2

Please always AVOID .Select and .Activate statements. I am sure you will learn this quickly as you go forward in VBA.

I have modified the solution given above by CDP1802, though it would work fine. But in case if you have variable number of rows in the sheet "Account" next time the data will not be copied till the end. Hence this modification -

add lrowD and lrowA to find last row in Department and Accounts respectively

Sub Macro2()

Dim lrow As Long, i As Integer
Dim lrowD as long, lrowA as long

Application.ScreenUpdating = False


'lrowD = Sheets("Departments").Cells(Rows.Count, 1).End(xlUp).Row 'Not using it currently
lrowA = Sheets("Accounts").Cells(Rows.Count, 1).End(xlUp).Row


For i = 1 To 47
    lrow = Sheets("Account and Dpt").Cells(Rows.Count, 1).End(xlUp).Row

    Sheets("Accounts").Range("A2:A" & lrowA).Copy _
        Sheets("Account and Dpt").Range("A" & lrow + 1)
    
    Sheets("Departments").Range("B" & i + 1).Copy _
        Sheets("Account and Dpt").Range("B" & lrow + 1).Resize((lrowA-1))
    
Next i
Application.ScreenUpdating = True

End Sub

Answer 3

Update lrow after pasting the accounts

Option Explicit

Sub Macro1()
    '
    ' Macro1 Macro
    '
    Dim lrow As Long, i As Integer
    lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To 47
    
        Sheets("Accounts").Select
        Range("A2:A178").Select
        Selection.Copy
        
        Sheets("Account and Dpt").Select
        Range("A" & lrow + 1).Select
        ActiveSheet.Paste
        
        Sheets("Departments").Select '
        Range("B" & i + 1).Select
        Application.CutCopyMode = False
        Selection.Copy
            
        Sheets("Account and Dpt").Select
        lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    
        Range("B" & lrow).Select
        Range(Selection, Selection.End(xlUp).Offset(1)).Select
        ActiveSheet.Paste
    
    Next i
End Sub

Or more simply

Sub Macro2()
 
    Dim lrow As Long, i As Integer
    
    Application.ScreenUpdating = False
    For i = 1 To 47
        lrow = Sheets("Account and Dpt").Cells(Rows.Count, 1).End(xlUp).Row
    
        Sheets("Accounts").Range("A2:A178").Copy _
            Sheets("Account and Dpt").Range("A" & lrow + 1)
        
        Sheets("Departments").Range("B" & i + 1).Copy _
            Sheets("Account and Dpt").Range("B" & lrow + 1).Resize(177)
        
    Next i
    Application.ScreenUpdating = True

End Sub