Help on VBA loop - paste on last row

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 Accounts" 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 in the picture I attached.

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

It is simply not working at all - it just pastes the accounts but that's it, and I don't understand why. Could you please help me fixing it ?

Thank you!!

Hello,

Please find attached the file I am struggling with - I manually did an example of what I am trying to achieve in the sheet "Account and Department"

Again, thank you so much for your help!

Quote from KjBox

Thanks. You have 177 Accounts and 45 Departments, so you want every account listed with every department (a total of 7,965 rows of data)?

Yes - I know it's a lot, but most of the files I deal with have 10k lines. What I mostly need is to understand the code to achieve it, and/or why mine isn't producing the expected result. As I am a newbie, I need that to learn

Quote from jolivanes

Like so?

Code

Sub Maybe()
Dim nrArr, depArr, i As Long
nrArr = Sheets("Accounts").Range("B2:B" & Sheets("Accounts").Cells(Rows.Count, 2).End(xlUp).Row)
depArr = Sheets("Departments").Range("E2:E" & Sheets("Departments").Cells(Rows.Count, 5).End(xlUp).Row)
With Sheets("Account and Dpt")
.UsedRange.ClearContents
.Cells(1, 1).Resize(, 2) = Array("Account", "Department")
For i = LBound(depArr) To UBound(depArr)
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(nrArr)) = nrArr
.Cells(.Rows.Count, 2).End(xlUp).Offset(1).Resize(UBound(nrArr)) = depArr(i, 1)
Next i
End With
End Sub

Display More

It worked perfect;y!! I will do some research to better understand your code, but thank you so much!

Quote from KjBox

Try the attached, I added a button to the Accounts sheet, click it to run the macro.

Macro assigned to the button:

Code

Sub Accounts_Departments()
    Dim x, y, z, i As Long, ii As Long, iii As Long
    
' Load array x with all Accounts and array y with all Departments
    x = Sheets("Accounts").Cells(1).CurrentRegion.Columns(2)
    y = Sheets("Departments").Cells(1).CurrentRegion.Columns(5)
    
' Size array z to accept all Departments for all Accounts
    ReDim z(1 To (UBound(y, 1) - 1) * (UBound(x, 1) - 1) + UBound(x, 1), 1 To 2)
    
' Add the hearers to array z
    z(1, 1) = "Account": z(1, 2) = "Department"
    
' Loop through arrays x and y, add data to array z
    For i = 2 To UBound(y, 1)
        For ii = 2 To UBound(x, 1)
            z(ii + iii, 1) = x(ii, 1): z(ii + iii, 2) = y(i, 1)
        Next
        iii = iii + (UBound(x, 1) - 1)  'This advances the ref for array z to accept the next Department
    Next
    
' Clear any existing data in Account and Dpt sheet
' Then place the contents of array z onto the sheet
' Then set the formatting
    With Sheets("Account and Dpt")
        .Cells(1).CurrentRegion.Clear
        .Cells(1, 1).Resize(UBound(z, 1), 2) = z
        .Cells(1).CurrentRegion.Columns(1).HorizontalAlignment = xlLeft
        With .Cells(1, 1).Resize(, 2)
            .Font.Bold = 1
            .HorizontalAlignment = -4108
            .Columns.AutoFit
        End With
        .Activate
        Application.Goto [a1]
    End With
    
End Sub

Display More

Works perfectly too!! Thank you very much, I realize that I have so much to learn...