Copy paste a list of names X amount of times based on how many IDs given

[drop05]

Hello I have a list of names in a sheet called "List" and a list of IDs given. I am trying to use VBA to take that list of names and copy it into another sheet called "Output" and and paste it in column A starting at row 3 and do it X amount of times and X is the number of IDs so if there is two IDs given then the list of names is pasted twice and also the first paste has the first ID and the second time pasting it has the second ID and the ID goes two columns over in column C.
There is also formulas in column B and D and trying to get those to go down with the list as well, the formula for column B is =IF(A3<>"","Go","")
and in column C the formula is =IF(A3<>"","ACT","")

here is an example of a list of names and a list of ID provided

there are 4 names and 2 ideas so when pasting there should be, at least from this example the four names with ID 12345 and that would be from A3 to A6 since there is 4 names and the same ID 12345 should be with those names from C3 to C6.
and since there is 2 ID there the same list of names is used and put into the next open cell open in A so in this example case A7 to A10 and the second ID 54321 is put two columns over in column C from C7 to C10. Would consider that there can be X amount of names and V amount of IDs so considering for name from A2 to the last row used in that column and the IDs from C2 to the last row used in that column

here is an example output from the example list

thank you in advance!

 

[bebo021999]

With input data in Sheet1
Output results in sheet "Output"

Option Explicit
Sub insert()
Dim lr&, i&, j&, k&, rng, arr(1 To 100000, 1 To 4)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:C" & lr)
    For i = 1 To UBound(rng)
        If Not IsEmpty(rng(i, 3)) Then
            For j = 1 To UBound(rng)
                k = k + 1
                arr(k, 1) = rng(j, 1)
                arr(k, 2) = "Go"
                arr(k, 3) = rng(i, 3)
                arr(k, 4) = "ACT"
            Next
        End If
    Next
End With
With Sheets("Output")
    .Range("A2:D100000").ClearContents
    .Range("A2").Resize(k, 4).Value = arr
End With
End Sub

 

[drop05]

With input data in Sheet1
Output results in sheet "Output"

Option Explicit
Sub insert()
Dim lr&, i&, j&, k&, rng, arr(1 To 100000, 1 To 4)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:C" & lr)
    For i = 1 To UBound(rng)
        If Not IsEmpty(rng(i, 3)) Then
            For j = 1 To UBound(rng)
                k = k + 1
                arr(k, 1) = rng(j, 1)
                arr(k, 2) = "Go"
                arr(k, 3) = rng(i, 3)
                arr(k, 4) = "ACT"
            Next
        End If
    Next
End With
With Sheets("Output")
    .Range("A2:D100000").ClearContents
    .Range("A2").Resize(k, 4).Value = arr
End With
End Sub

Thank for you this it is very helpful! I do have a question, i was wondering if there was a way with the same process but moving the IDs list to another sheet "IDs", doing the same thing with the same output

Names (note names listed starts on row 3 incase you see that row 2 is hidden)

OTP UserComponentCreate_V1 (1).xlsm
	A	B
1	Names
3	James
4	Karen
5	Nick
6	Rudy
7
8
Names

IDs (IDs unlike names start on row 2)

OTP UserComponentCreate_V1 (1).xlsm
	A	B
1	IDs
2	12345
3	54321
4	22222
5
6
7
IDs

Output

OTP UserComponentCreate_V1 (1).xlsm
	A	B	C	D	E
1	Name	Type	ID	Activity
2
3	James	GO	12345	ACT
4	Karen	GO	12345	ACT
5	Nick	GO	12345	ACT
6	Rudy	GO	12345	ACT
7	James	GO	54321	ACT
8	Karen	GO	54321	ACT
9	Nick	GO	54321	ACT
10	Rudy	GO	54321	ACT
11	James	GO	22222	ACT
12	Karen	GO	22222	ACT
13	Nick	GO	22222	ACT
14	Rudy	GO	22222	ACT
15
16
Output

thank you in advance!

 

[bebo021999]

Try:

Option Explicit
Sub insert()
Dim lr&, i&, j&, k&, rngName, rngID, arr(1 To 100000, 1 To 4)
With Sheets("Names")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rngName = .Range("A3:A" & lr)
End With
With Sheets("IDs")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rngID = .Range("A2:A" & lr)
End With
    For j = 1 To UBound(rngID)
        For i = 1 To UBound(rngName)
            If Not IsEmpty(rngName(i, 1)) And Not IsEmpty(rngID(j, 1)) Then
                k = k + 1
                arr(k, 1) = rngName(i, 1)
                arr(k, 2) = "Go"
                arr(k, 3) = rngID(j, 1)
                arr(k, 4) = "ACT"
            End If
        Next
    Next
With Sheets("Output")
    .Range("A2:D100000").ClearContents
    .Range("A3").Resize(k, 4).Value = arr
End With
End Sub