VBA and data layout

[KaTa]

Hello!

At the moment I'm doing manual work to get desired data format. All this formatting is done in one sheet, Sheet1.

First I group cells by Header1 and then copy/paste to get needed format.
In desired data format line between Header4 different values.

Is it possible to do this all with VBA?

Table.xlsx
	A	B	C	D	E	F	G	H
1	raw data format from A1
2	Header1	Header2	Header3	Header4	Header5	Header6	Header7	Header8
3	x	1	2	3	4	5	6	7
4	x	1	2	3	5	6	7	8
5	x	1	2	4	8	9	7	10
6	y	1	2	6	10	11	8	8
7	y	1	2	7	12	13	8	14
8	z	1	2	10	14	15	12	13
9	z	1	2	8	16	17	14	12
10	z	1	2	8	18	19	11	14
11
12
13
14	Desired data format from A1
15	Header1	Header2	Header3
16	x	1	2
17	Header4	Header5	Header6	Header7	Header8	Header8
18	3	4	5	6	7	8
19	3	5	6	7	8	9
20	4	8	9	7	10	8
21
22
23	Header1	Header2	Header3
24	y	1	2
25	Header4	Header5	Header6	Header7	Header8	Header8
26	6	10	11	8	8	13
27	7	12	13	8	14	15
28
29
30	Header1	Header2	Header3
31	z	1	2
32	Header4	Header5	Header6	Header7	Header8	Header8
33	10	14	15	12	13	11
34	8	16	17	14	12	13
35	8	18	19	11	14	15
36
37
Leht1

 

[KaTa]

Hello again,

Try the following macro. Your data on sheet1, the results on sheet2.

Sub Format_Data_1()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim cell As Range
  Dim dic As Object
  Dim ky As Variant
  Dim lr As Long, lr2 As Long
 
  Application.ScreenUpdating = False
 
  Set dic = CreateObject("Scripting.Dictionary")
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  For Each cell In sh1.Range("A2:A" & lr)
    dic(cell.Value) = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
  Next
 
  sh2.Range("A:E").ClearContents
  lr2 = 1
  For Each ky In dic.Keys
    sh1.Range("A1:H" & lr).AutoFilter 1, ky
    sh2.Range("A" & lr2).Resize(1, 3).Value = sh1.Range("A1:C1").Value
    sh2.Range("A" & lr2 + 1).Resize(1, 3).Value = Split(dic(ky), "|")
    sh2.Range("A" & lr2 + 2).Resize(1, 5).Value = sh1.Range("D1:H1").Value
    sh1.AutoFilter.Range.Range("D2:H" & lr).Copy sh2.Range("A" & lr2 + 3)
    lr2 = sh2.Range("A" & Rows.Count).End(3).Row + 3
  Next ky
  sh1.ShowAllData
  Application.ScreenUpdating = True
End Sub

Hello,
now I have a new problem. Sometime Sheet1 and RangeA is empty but other Ranges with values. I need to group Sheet1 RangeA empty data also to Sheet2.
Thank you in advance!