Expand Data set based on a Summary Table

hassanleo1987 · Apr 16, 2023

Hi!

I would like to request the help of VBA experts on a tedious & time consuming problem I have facing.
Currently I have a daily data summary in a compressed / summarized format that I need to expand vertically which later will be incorporated in a database of future analysis and forecasting.
The current data structure is as following:

Sample.xlsx

A

B

C

D

E

F

G

H

3

Data_N

Max.Val

AAA

BBB

CCC

DDD

EEE

FFF

4

A

6

5

1

6

3

0

1

5

B

8

6

2

5

8

5

2

6

C

6

2

3

4

2

6

1

7

D

5

3

4

3

1

0

5

8

E

6

0

5

2

4

3

6

9

F

8

1

6

1

5

8

Sheet1

Cell Formulas
Range	Formula
B4:B9	B4	=MAX(C4:H4)

The Column B has the max value of Item A for next 6 instances i.e., max value from Column AAA to FFF is 6

The desired Data structure should expand vertically where A is repeated in consective rows until max value of rows are filled. (6 rows with A).
Next Column AAA to FFF are filled with a repeated value, lets say 1 as per each column's respective number is current data set. AAA=5, BBB=1 and so on for Data_N = A.

Same senario is implemented on each distinct value in Data_N. Resultant Data Struture should be as following:



Required Expanded Data Model

Data_N	AAA	BBB	CCC	DDD	EEE	FFF
A	1	1	1	1		1
A	1		1	1
A	1		1	1
A	1		1
A	1		1
A			1
B	1	1	1	1	1	1
B	1	1	1	1	1	1
B	1		1	1	1
B	1		1	1	1
B	1		1	1	1
B	1			1
B				1
B				1
C	1	1	1	1	1	1
C	1	1	1	1	1
C		1	1		1
C			1		1
C					1
C					1
D	1	1	1	1		1
D	1	1	1			1
D	1	1	1			1
D		1				1
D						1
E		1	1	1	1	1
E		1	1	1	1	1
E		1		1	1	1
E		1		1		1
E		1				1
E						1
F	1	1	1	1	1	1
F		1		1	1	1
F		1		1	1	1
F		1		1	1	1
F		1		1	1	1
F		1				1
F						1
F						1

The solution can be single or multiple sheet.

Kindly look into this problem and advice of a solution with VBA.

Thanks!

Snakehips · Apr 16, 2023

@hassanleo1987 Does this help?

VBA Code:

Sub Re_Structure()

Dim dnr As Long
Dim mv As Integer
Dim lr As Long
Dim r As Long
Dim lnr As Long
Dim ldr As Long
Dim MaxVal As Long
Dim DataN As String
Dim Rng As Range

'******* Assumes headers existK3:Q3  ??

Application.ScreenUpdating = False   'Aid speed and visuals by suspending screen updating

'***** Clear any existing K4:Q data  ??????
lr = Cells(Rows.Count, 11).End(xlUp).Row + 1  'last row in K

Range("K4:Q" & lr).ClearContents

'Get last row in column A
lr = Cells(Rows.Count, 1).End(xlUp).Row
'dnr = start row of column K for current  Data_N
dnr = 4  'initially row 4


'loop through all rows of column A
For r = 4 To lr
    MaxVal = Cells(r, 2)   'Max.Val
    DataN = Range("A" & r)  'Data_N value
    
    ldr = dnr + MaxVal - 1   'ldr  last data  row in K for current Data_N
    
    Set Rng = Range("K" & dnr & ":K" & ldr)    'K range for current Data_N

    Rng.Value = DataN    ' Apply Data_N to range in K
    
    dnr = ldr + 1  'update start row for next Data_N in K
      
      'Loop through offset columns to get each number of instances, n
        For c = 1 To 6
        
            n = Cells(r, 2).Offset(0, c)  'number of instances found in offset from column 2. ie B
            'insert 1 n times in column K offset
            If n > 0 Then Rng.Offset(0, c).Resize(n, 1).Value = 1  'Ignore and prevent an errorif n = 0
            
        Next c  'Next offset


Next r  'next row of data in A

Application.ScreenUpdating = True   'Re-establish screen updating.

End Sub

Book1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

1

2

3

Data_N

Max.Val

AAA

BBB

CCC

DDD

EEE

FFF

Data_N

AAA

BBB

CCC

DDD

EEE

FFF

4

A

6

5

1

6

3

0

1

A

1

5

B

8

6

2

5

8

5

2

A

1

6

C

6

2

3

4

2

6

1

A

1

7

D

5

3

4

3

1

0

5

A

1

8

E

6

0

5

2

4

3

6

A

1

9

F

8

1

6

1

5

8

A

1

10

B

1

11

B

1

12

B

1

13

B

1

14

B

1

15

B

1

16

B

1

17

B

1

18

C

1

19

C

1

20

C

1

Sheet1

Cell Formulas
Range	Formula
B4:B9	B4	=MAX(C4:H4)

fjns · Apr 16, 2023

Hi, see the linked file for a possible solution (without VBA)...

The formulas used in the table...
Sheet1!I4: =IF(A4="","",SUM(B$4:B4)) (Range: I4:I10...)
Sheet1!A4: =IF(ROW()>SUM(Sheet1!B:B)+3,"",INDEX(Sheet1!A:A,IFERROR(MATCH(ROW()-4,Sheet1!I:I),3)+1)) (Range: A4:A50...)
Sheet1!B4: =IF(ROW()>SUM(Sheet1!$B:$B)+3,"",IF(INDEX(Sheet1!C:C,IFERROR(MATCH(ROW()-4,Sheet1!$I:$I),3)+1)>ROW()-4-IFERROR(INDEX(Sheet1!$I:$I,MATCH(ROW()-4,Sheet1!$I:$I)),0),1,"")) (Range: B4:G50...)

Expand.xlsx

hassanleo1987 · Apr 16, 2023

Snakehips said:

@hassanleo1987 Does this help?

VBA Code:

Sub Re_Structure()

Dim dnr As Long
Dim mv As Integer
Dim lr As Long
Dim r As Long
Dim lnr As Long
Dim ldr As Long
Dim MaxVal As Long
Dim DataN As String
Dim Rng As Range

'******* Assumes headers existK3:Q3  ??

Application.ScreenUpdating = False   'Aid speed and visuals by suspending screen updating

'***** Clear any existing K4:Q data  ??????
lr = Cells(Rows.Count, 11).End(xlUp).Row + 1  'last row in K

Range("K4:Q" & lr).ClearContents

'Get last row in column A
lr = Cells(Rows.Count, 1).End(xlUp).Row
'dnr = start row of column K for current  Data_N
dnr = 4  'initially row 4


'loop through all rows of column A
For r = 4 To lr
    MaxVal = Cells(r, 2)   'Max.Val
    DataN = Range("A" & r)  'Data_N value
   
    ldr = dnr + MaxVal - 1   'ldr  last data  row in K for current Data_N
   
    Set Rng = Range("K" & dnr & ":K" & ldr)    'K range for current Data_N

    Rng.Value = DataN    ' Apply Data_N to range in K
   
    dnr = ldr + 1  'update start row for next Data_N in K
     
      'Loop through offset columns to get each number of instances, n
        For c = 1 To 6
       
            n = Cells(r, 2).Offset(0, c)  'number of instances found in offset from column 2. ie B
            'insert 1 n times in column K offset
            If n > 0 Then Rng.Offset(0, c).Resize(n, 1).Value = 1  'Ignore and prevent an errorif n = 0
           
        Next c  'Next offset


Next r  'next row of data in A

Application.ScreenUpdating = True   'Re-establish screen updating.

End Sub

Book1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

1

2

3

Data_N

Max.Val

AAA

BBB

CCC

DDD

EEE

FFF

Data_N

AAA

BBB

CCC

DDD

EEE

FFF

4

A

6

5

1

6

3

0

1

A

1

5

B

8

6

2

5

8

5

2

A

1

6

C

6

2

3

4

2

6

1

A

1

7

D

5

3

4

3

1

0

5

A

1

8

E

6

0

5

2

4

3

6

A

1

9

F

8

1

6

1

5

8

A

1

10

B

1

11

B

1

12

B

1

13

B

1

14

B

1

15

B

1

16

B

1

17

B

1

18

C

1

19

C

1

20

C

1

Sheet1

Cell Formulas
Range	Formula
B4:B9	B4	=MAX(C4:H4)

@Snakehips Thanks a lot. It works perfectly and will save me a great deal of time.

hassanleo1987 · Apr 16, 2023

fjns said:
Hi, see the linked file for a possible solution (without VBA)...

The formulas used in the table...
Sheet1!I4: =IF(A4="","",SUM(B$4:B4)) (Range: I4:I10...)
Sheet1!A4: =IF(ROW()>SUM(Sheet1!B:B)+3,"",INDEX(Sheet1!A:A,IFERROR(MATCH(ROW()-4,Sheet1!I:I),3)+1)) (Range: A4:A50...)
Sheet1!B4: =IF(ROW()>SUM(Sheet1!$B:$B)+3,"",IF(INDEX(Sheet1!C:C,IFERROR(MATCH(ROW()-4,Sheet1!$I:$I),3)+1)>ROW()-4-IFERROR(INDEX(Sheet1!$I:$I,MATCH(ROW()-4,Sheet1!$I:$I)),0),1,"")) (Range: B4:G50...)

Expand.xlsx

View attachment 89833

View attachment 89834

View attachment 89835

@fjns , Your solution is also perfect but for a smaller data as I had presented in the sample, But I have a large data set that needs a VBA solution to minimize the processing time.
Thanks a lot for you effort!

fjns · Apr 17, 2023

Hi, I am very glad that the formulas work.
If I have enough knowledge, I am happy to help at any time.

Expand Data set based on a Summary Table

hassanleo1987

Board Regular

Excel Facts

Snakehips

Well-known Member

fjns

Board Regular

hassanleo1987

Board Regular

hassanleo1987

Board Regular

fjns

Board Regular

Similar threads

Forum statistics

Share this page

Expand Data set based on a Summary Table

hassanleo1987

Board Regular

Excel Facts

Snakehips

Well-known Member

fjns

Board Regular

hassanleo1987

Board Regular

hassanleo1987

Board Regular

fjns

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock