VBA - copy multiple column data in to a list

[rashid67]

I need a vba code to copy multiple columns from sheet1 and paste as list in sheet2

Here is current data format in sheet1

	H	G	H	I	J	K	L	M
16			001/2018		002/2018		003/2018
17			8000		9000		9500
18			London		NewYork		Paris
19	GL acct	Name	Plan	Actual	Plan	Actual	Plan	Actual
20	1000	Salary	500	450	500	400	500	390
21	1001	Travel	150	135	150	120	150	117
22	1002	Meal	50	45	50	40	50	39

<tbody>
</tbody>

New format in sheet2 -list

Date		Site no	Site	GL acct	Name	Plan	Actual
001/2018		8000	London	1000	Salary	500	450
001/2018		8000	London	1001	Travel	150	135
001/2018		8000	London	1002	Meal	50	45
002/2018		9000	NewYork	1000	Salary	500	400
002/2018		9000	NewYork	1001	Travel	150	120
002/2018		9000	NewYork	1002	Meal	50	40
003/2018		9500	Paris	1000	Salary	500	390
003/2018		9500	Paris	1001	Travel	150	117
003/2018		9500	Paris	1002	Meal	50	39

<tbody>
</tbody>

 

[footoo]

Are the data in rows 16:17 in columns H, J, L ; or in columns G,I,K and centered or merged?

 

[rashid67]

data in row 16:18 starts from column I and it is not merged or centered

data in row 20:22 starts from column G

Thanks.

 

[footoo]

data in row 16:18 starts from column I and it is not merged or centered

data in row 20:22 starts from column G

Thanks.

That doesn't match what you posted.

Are the columns like this :
Col F - GL acct
Col G - Name
Col H - Plan
Col I - Actual
Col J - Plan
Col K - Actual
Col L - Plan
Col M - Actual

Or like this :
Col G - GL acct
Col H - Name
Col I - Plan
Col J - Actual
Col K - Plan
Col L - Actual
Col M - Plan
Col N - Actual

 

[rashid67]

its like this

ol G - GL acct
Col H - Name
Col I - Plan
Col J - Actual
Col K - Plan
Col L - Actual
Col M - Plan
Col N - Actual

 

[rashid67]

its like this

Col G - GL acct
Col H - Name
Col I - Plan
Col J - Actual
Col K - Plan
Col L - Actual
Col M - Plan
Col N - Actual

 

[footoo]

Sub FT()
Dim rng As Range, c%
Application.ScreenUpdating = False
ActiveSheet.Copy After:=ActiveSheet
[A:C].Delete
[A:C].ClearContents
[A19] = "Date"
[B19] = "Site no"
[C19] = "Site"
Set rng = Range([F16], Cells(16, Columns.Count).End(xlToLeft))
For c = 1 To rng.Columns.Count Step 3
    rng(1, c).Resize(3).Copy
    Cells(Rows.Count, "A").End(xlUp)(2).Resize(3, 3).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Next
Set rng = Range([H20], Cells(20, Columns.Count).End(xlToLeft))
For c = 1 To rng.Columns.Count Step 3
    rng(1, c).Resize(3, 3).Copy Cells(Rows.Count, "E").End(xlUp)(2)
Next
Rows("1:18").Delete
rng.EntireColumn.Delete
[D2:D4].Copy Range([D5], Cells(Rows.Count, "C").End(xlUp)(1, 2))
[A:C].EntireColumn.AutoFit
End Sub