Consolidate data from multiple sheets

[ExcelNewbie2020]

I have multiple sheets (accumulated daily) with similar formats and the date is found cell A1. I hope its possible to extract and consolidate some data of those sheet and put it in a separate sheet. As shown below table.

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W
1
2	Sheet1						Sheet2						Sheet3							Sheet4
3	20-01-2023						21-01-2023						22-01-2023							23-01-2023
4
5
6
7	Dept	Name	Amount				Dept	Name	Amount				Dept	Name	Amount					Dept	Name	Amount
8	Acctg	name1	1				Marketing	name4	5				Sales	name7	9					Acctg	name10	13
9	Marketing	name2	2				Sales	name5	6				Acctg	name8	10					Marketing	name11	14
10	Sales	name3	3				Acctg	name6	7				Acctg	name9	11					HR	name12	15
11	HR	name4	4				HR	name7	8				HR	name10	12					HR	name13	16
12
13
14
15
16
17
18
19
20
21
22		SHEET 5
23		EXPECTED RESULT
24
25
26			ACCTG						Marketing						Sales					HR
27		Date	Name	Amount					Date	Name	Amount			Date	Name	Amount			Date	Name	Amount
28		20-01-2023	name1	1					20-01-2023	name2	2			20-01-2023	name3	3			20-01-2023	name4	4
29		21-01-2023	name6	7					21-01-2023	name4	5			21-01-2023	name5	6			21-01-2023	name7	8
30		22-01-2023	name8	10					23-01-2023	name11	14			22-01-2023	name7	9			22-01-2023	name10	12
31		22-01-2023	name9	11															23-01-2023	name12	15
32		23-01-2023	name10	13															23-01-2023	name13	16
33
34
35
Sheet1

 

[JEC]

Here VBA solution

Sub jec()
 Dim dic As Object, sh, ar, ky, x As Long, i As Long
 Set dic = CreateObject("scripting.dictionary")
 
 For Each sh In Sheets(Array(1, 2, 3, 4))
    ar = sh.Range("A5").CurrentRegion
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then dic(ar(i, 1)) = Array(ar(i, 1), CreateObject("scripting.dictionary"))
        dic(ar(i, 1))(1)(dic(ar(i, 1))(1).Count) = Array(CLng(sh.Cells(1, 1)), ar(i, 2), ar(i, 3))
    Next
 Next
 With Sheets(5).Cells(1, 1)
   For Each ky In dic.keys
      .Offset(, x) = ky
      .Offset(1, x).Resize(dic(ky)(1).Count, 3) = Application.Index(dic(ky)(1).items, 0, 0)
      x = x + 6
   Next
 End With
End Sub

I got started with this format (in the first 4 sheets)
- date in A1
- data starting from A5

Book1
	A	B	C
1	20-1-2023
2
3
4
5	Dept	Name	Amount
6	Acctg	name1	1
7	Marketing	name2	2
8	Sales	name3	3
9	HR	name4	4
Sheet1

This is the output

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1	Acctg						Marketing						Sales						HR
2	20-1-2023	name1	1				20-1-2023	name2	2				20-1-2023	name3	3				20-1-2023	name4	4
3	21-1-2023	name6	7				21-1-2023	name4	5				21-1-2023	name5	6				21-1-2023	name7	8
4	22-1-2023	name8	10				23-1-2023	name11	14				22-1-2023	name7	9				22-1-2023	name10	12
5	22-1-2023	name9	11																23-1-2023	name12	15
6	23-1-2023	name10	13																23-1-2023	name13	16
7
8
9
Sheet5

 

[JEC]

Forgot the headers

Sub jec()
 Dim dic As Object, sh, ar, ky, x As Long, i As Long
 Set dic = CreateObject("scripting.dictionary")
 
 For Each sh In Sheets(Array(1, 2, 3, 4))
    ar = sh.Range("A5").CurrentRegion
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then dic(ar(i, 1)) = Array(ar(i, 1), CreateObject("scripting.dictionary"))
        dic(ar(i, 1))(1)(dic(ar(i, 1))(1).Count) = Array(CLng(sh.Cells(1, 1)), ar(i, 2), ar(i, 3))
    Next
 Next
 With Sheets(5).Cells(1, 1)
   For Each ky In dic.keys
      .Offset(, x) = ky
      .Offset(1, x) = Array("Date", "Name", "Amount")
      .Offset(2, x).Resize(dic(ky)(1).Count, 3) = Application.Index(dic(ky)(1).items, 0, 0)
      x = x + 6
   Next
 End With
End Sub

 

[JEC]

Previous code could be deleted.
This is the one, I missed a word

Sub jec()
 Dim dic As Object, sh, ar, ky, x As Long, i As Long
 Set dic = CreateObject("scripting.dictionary")
 
 For Each sh In Sheets(Array(1, 2, 3, 4))
    ar = sh.Range("A5").CurrentRegion
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then dic(ar(i, 1)) = Array(ar(i, 1), CreateObject("scripting.dictionary"))
        dic(ar(i, 1))(1)(dic(ar(i, 1))(1).Count) = Array(CLng(sh.Cells(1, 1)), ar(i, 2), ar(i, 3))
    Next
 Next
 With Sheets(5).Cells(1, 1)
   For Each ky In dic.keys
      .Offset(, x) = ky
      .Offset(1, x).Resize(,3) = Array("Date", "Name", "Amount")
      .Offset(2, x).Resize(dic(ky)(1).Count, 3) = Application.Index(dic(ky)(1).items, 0, 0)
      x = x + 6
   Next
 End With
End Sub

 

[ExcelNewbie2020]

Previous code could be deleted.
This is the one, I missed a word

Sub jec()
 Dim dic As Object, sh, ar, ky, x As Long, i As Long
 Set dic = CreateObject("scripting.dictionary")
 
 For Each sh In Sheets(Array(1, 2, 3, 4))
    ar = sh.Range("A5").CurrentRegion
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then dic(ar(i, 1)) = Array(ar(i, 1), CreateObject("scripting.dictionary"))
        dic(ar(i, 1))(1)(dic(ar(i, 1))(1).Count) = Array(CLng(sh.Cells(1, 1)), ar(i, 2), ar(i, 3))
    Next
 Next
 With Sheets(5).Cells(1, 1)
   For Each ky In dic.keys
      .Offset(, x) = ky
      .Offset(1, x).Resize(,3) = Array("Date", "Name", "Amount")
      .Offset(2, x).Resize(dic(ky)(1).Count, 3) = Application.Index(dic(ky)(1).items, 0, 0)
      x = x + 6
   Next
 End With
End Sub

thanks man it works.. I wonder, how can i tweak this code if there are more than 20 sheets i need to consolidate?.. really appreciated