Move data onto blank row below Excel from multiple columns with VBA macro - excel

Question

I currently have data in the following format:
Name 1 | Email 1 | ID 1 | Address 1 Street | Address 1 Suburb | Address 1 City | Address 2 Street | Address 2 Suburb | Address 2 City | Address 3 Street | Address 3 Suburb | Address 3 City
<NEW LINE>
Name 2 | Email 2 | ID 2 | Address 1 Street | Address 1 Suburb | Address 1 City | Address 2 Street | Address 2 Suburb | Address 2 City
etc.
And I need it to look like the following:
Name 1 | Email 1 | ID 1 | Address 1 Street | Address 1 Suburb | Address 1 City
<NEW LINE>
Name 1 | Email 1 | ID 1 | Address 2 Street | Address 2 Suburb | Address 2 City
<NEW LINE>
Name 1 | Email 1 | ID 1 | Address 3 Street | Address 3 Suburb | Address 3 City
<NEW LINE>
Name 2 | Email 2 | ID 2 | Address 1 Street | Address 1 Suburb | Address 1 City
<NEW LINE>
Name 2 | Email 2 | ID 2 | Address 2 Street | Address 2 Suburb | Address 2 City
etc.
What I have so far in my spreadsheet is in column A is a COUNTA formula to work out the number of rows we need to insert below each row to allow for the data to be duplicated which is calculating fine. From this I have used the following code to insert these number of lines which is also working fine.
Sub ProcessAddressLabels()
For N = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(N, 1) <> "" And Cells(N, 1) <> 1 Then
Rows(N + 1 & ":" & N + Cells(N, 1) - 1).Insert
NumValues = Cells(N, 1)
End If
Next N
End Sub
What I am not sure from here is how to copy each set of 3 cells from the end and place it along with the duplicated user data onto the lines below!
Any help is much appreciated and I hope I explained this simply enough!

Answer 1

Give this a try:
Sub Test()
Dim rw As Range, n As Long, i As Long, x As Long
Set rw = ActiveSheet.Rows(1) 'starting row
Do While rw.Cells(1).Value <> ""
'how many sets of addresses to move?
x = Application.Ceiling((Application.CountA(rw) - 6) / 3, 1)
If x > 0 Then
'insert required rows
rw.Offset(1, 0).Resize(x).Insert
For i = 1 To x
'copy common cells
rw.Cells(1).Resize(1, 3).Copy rw.Cells(1).Offset(i, 0)
'cut each address block
rw.Cells(7 + ((i - 1) * 3)).Resize(1, 3).Cut rw.Cells(1).Offset(i, 3)
Next i
End If
'move to next "new" row
Set rw = rw.Offset(1 + x, 0)
Loop
End Sub

Answer 2

I cannot say I fully understood all your needs, however
would something like this help:
Dim sht As Worksheet
Set sht = ActiveSheet
' copy the range C1:F1 to the start of the third row.
sht.range("C1:F1").Copy Destination:=Worksheets("Sheet1").range("A3")