SOLVED

VBA Copy cells fill down on another sheet with last row

Copper Contributor

Greetings,

I have a spreadsheet with a tab called Clerk. It has names listed under column A. I can't use A2:A5 because the list could grow. I need all the names pasted and filled down on another tab in the same workbook called Sheet3 in column P.

kbashaw_0-1716398717161.png

I need column P below to have the names fill down in order until the last row recorded on column A in that spreadsheet. For example: Jane, Jon, Doe, John, Jane, Jon, Doe etc. until it reaches the end of Sheet3.

kbashaw_1-1716398854150.png

Can anyone help me with this VBA macro?

Thank you!

 

2 Replies
best response confirmed by kbashaw (Copper Contributor)
Solution

@kbashaw If I've understood everything correctly, the following code should work:

 

Option Explicit

Sub RepeatClerkNames()

    Dim wsSource As Worksheet, data As Variant, k As Long
    Set wsSource = Sheets("Clerk")
    data = wsSource.Range("A2:A" & wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row).Value
    k = UBound(data, 1)

    Dim wsOutput As Worksheet, arr() As Variant, i As Long, j As Long
    Set wsOutput = Sheets("Sheet3")
    ReDim arr(1 To wsOutput.Cells(wsOutput.Rows.Count, 1).End(xlUp).Row - 1, 1 To 1)
    j = 1
    For i = 1 To UBound(arr, 1)
        arr(i, 1) = data(j, 1)
        j = IIf(j = k, 1, j + 1)
    Next i

    wsOutput.Range("P2").Resize(UBound(arr, 1)).Value = arr

End Sub

 

Adjust the worksheet names, if necessary. Cheers!

Thank you!!!!!! It worked!
1 best response

Accepted Solutions
best response confirmed by kbashaw (Copper Contributor)
Solution

@kbashaw If I've understood everything correctly, the following code should work:

 

Option Explicit

Sub RepeatClerkNames()

    Dim wsSource As Worksheet, data As Variant, k As Long
    Set wsSource = Sheets("Clerk")
    data = wsSource.Range("A2:A" & wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row).Value
    k = UBound(data, 1)

    Dim wsOutput As Worksheet, arr() As Variant, i As Long, j As Long
    Set wsOutput = Sheets("Sheet3")
    ReDim arr(1 To wsOutput.Cells(wsOutput.Rows.Count, 1).End(xlUp).Row - 1, 1 To 1)
    j = 1
    For i = 1 To UBound(arr, 1)
        arr(i, 1) = data(j, 1)
        j = IIf(j = k, 1, j + 1)
    Next i

    wsOutput.Range("P2").Resize(UBound(arr, 1)).Value = arr

End Sub

 

Adjust the worksheet names, if necessary. Cheers!

View solution in original post