Macro Help - Creating a report using data from another sheet

[Johnny Thunder]

Hello All,

I have a spreadsheet that contains data by Genre and Dates that flows left to right on my sheet but I need a way to convert the data into a more traditional style report that flows vertically. I have mocked up some sample data to assist in my explanation so hopefully that helps.

Currently for each genre there is an original amount that is used and then allocated by the user manually across the dates they choose. The total allocation will always equal back to the original. Also, the dates will never have any gaps in the middle of the allocation.

Any help is appreciated. ?

Sheet 1 Data

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1	Genre	Amount	Date Range:	Oct-17	Nov-17	Dec-17	Jan-18	Feb-18	Mar-18	Apr-18	May-18	Jun-18	Jul-18	Aug-18	Sep-18	Oct-18	Nov-18	Dec-18	Jan-19
2	Rock	$ 750.00				$ 87.50	$ 87.50	$ 87.50	$ 87.50	$ 87.50	$ 87.50	$ 45.00	$ 45.00	$ 45.00	$ 45.00	$ 45.00
3	Classical	$ 1,200.00						$ 140.00	$ 140.00	$ 140.00	$ 140.00	$ 140.00	$ 140.00	$ 72.00	$ 72.00	$ 72.00	$ 72.00	$ 72.00
4	Folk	$ 3,000.00									$ 900.00	$ 1,500.00	$ 300.00	$ 300.00
Sheet1

My expected results on Sheet 2

Book1
	A	B	C
1	Genre	Caluclated Amount	Date
2	Rock	$ 87.50	Dec-17
3	Rock	$ 87.50	Jan-18
4	Rock	$ 87.50	Feb-18
5	Rock	$ 87.50	Mar-18
6	Rock	$ 87.50	Apr-18
7	Rock	$ 87.50	May-18
8	Rock	$ 45.00	Jun-18
9	Rock	$ 45.00	Jul-18
10	Rock	$ 45.00	Aug-18
11	Rock	$ 45.00	Sep-18
12	Rock	$ 45.00	Oct-18
13	Classical	$ 140.00	Feb-18
14	Classical	$ 140.00	Mar-18
15	Classical	$ 140.00	Apr-18
16	Classical	$ 140.00	May-18
17	Classical	$ 140.00	Jun-18
18	Classical	$ 140.00	Jul-18
19	Classical	$ 72.00	Aug-18
20	Classical	$ 72.00	Sep-18
21	Classical	$ 72.00	Oct-18
22	Classical	$ 72.00	Nov-18
23	Classical	$ 72.00	Dec-18
24	Folk	$ 900.00	May-18
25	Folk	$ 1,500.00	Jun-18
26	Folk	$ 300.00	Jul-18
27	Folk	$ 300.00	Aug-18
Sheet2

 

[DanteAmor]

Try this

Sub Creating_report()
  Dim sh1 As Worksheet, a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  Set sh1 = Sheets("Sheet1")
  lr = sh1.Range("A" & Rows.Count).End(3).Row
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  a = sh1.Range("A1", sh1.Cells(lr, lc)).Value2
  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 3)
  k = 1
  For i = 2 To UBound(a, 1)
    For j = 4 To UBound(a, 2)
      If a(i, j) <> "" Then
        b(k, 1) = a(i, 1)
        b(k, 2) = a(i, j)
        b(k, 3) = a(1, j)
        k = k + 1
      End If
    Next
  Next
  Sheets("Sheet2").Range("A2").Resize(k, 3).Value = b
End Sub

 

[Johnny Thunder]

Dante! Thanks for providing the code to test. I did get pulled off of the project for a few hours but plan on getting back to it this weekend so I will review and get back to you on the results. Thanks again!

 

[Johnny Thunder]

Dante,

Thank you for the help on this. So I tested the code and it definitely looks like it will work for what I need. I did run into a bit of an issue. So the sample data I provided was just that, a sample. I was hoping the code would be easy to manipulate to my actual layout for my spreadsheet but it is much more complex then what I am used to.

I am hoping it wouldn't be to hard to revise the code you provide based on the data below, its my actual data with some names removed.

I wanted to point out that my data starts in cell O7, I would need the values from cells O7, P7 repeated on Sheet2 as it builds the report. Also, the Date header that is needed starts in Cell T7:whatever the last column is but remain on row 7. I wanted to also point out as you can see from the sample there will be blank rows in between the data and totals as well, I use column O to drive the code to ensure I don't pick up blank rows and also so that I don't pick up the total.

I highlighted the data in the table below that is needed to build the report on Sheet2 Hopefully its a quick change to the code you provided to make this work. Thanks again for all your help.

Starting Sheet

Sample Table - Dates Grid.xlsx
	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK
1						Q1	Q1	Q1	Q2	Q2	Q2	Q3	Q3	Q3	Q4	Q4	Q4	Q1	Q1	Q1	Q2	Q2	Q2
2						FY19 Q1	FY19 Q1	FY19 Q1	FY19 Q2	FY19 Q2	FY19 Q2	FY19 Q3	FY19 Q3	FY19 Q3	FY19 Q4	FY19 Q4	FY19 Q4	FY20 Q1	FY20 Q1	FY20 Q1	FY20 Q2	FY20 Q2	FY20 Q2
3						FY19												FY20
4	Marketing Costs			Control Total		Oct-18	Nov-18	Dec-18	Jan-19	Feb-19	Mar-19	Apr-19	May-19	Jun-19	Jul-19	Aug-19	Sep-19	Oct-19	Nov-19	Dec-19	Jan-20	Feb-20	Mar-20
5	Title	Category	Amount	Sum Amount
6
7	Title 1	Genre 1	-	-				$ -	$ -	$ -	$ -	$ -	$ -	$ -	$ -	$ -	$ -	$ -
8	Title 2	Genre 2	750	750				$ 88	$ 88	$ 88	$ 88	$ 88	$ 88	$ 45	$ 45	$ 45	$ 45	$ 45
9	Title 3	Genre 3	1,200	1,200				$ 140	$ 140	$ 140	$ 140	$ 140	$ 140	$ 72	$ 72	$ 72	$ 72	$ 72
10	Title 4	Genre 4	500	500				$ 58	$ 58	$ 58	$ 58	$ 58	$ 58	$ 30	$ 30	$ 30	$ 30	$ 30
11	Title 5	Genre 5	1,200	1,200				$ 140	$ 140	$ 140	$ 140	$ 140	$ 140	$ 72	$ 72	$ 72	$ 72	$ 72
12	Title 6	Genre 6	925	925				$ 108	$ 108	$ 108	$ 108	$ 108	$ 108	$ 56	$ 56	$ 56	$ 56	$ 56
13	Title 7	Genre 7	452	452				$ 53	$ 53	$ 53	$ 53	$ 53	$ 53	$ 27	$ 27	$ 27	$ 27	$ 27
14	Title 8	Genre 8	3,000	3,000														$ 900	$ 1,500	$ 300	$ 300
15		Total	8,027	8,027
16
17	Title 9	Genre 9	-	-					$ -	$ -	$ -	$ -	$ -	$ -	$ -	$ -	$ -	$ -	$ -
18	Title 10	Genre 10	750	750					$ 88	$ 88	$ 88	$ 88	$ 88	$ 88	$ 45	$ 45	$ 45	$ 45	$ 45
19	Title 11	Genre 11	1,200	1,200					$ 140	$ 140	$ 140	$ 140	$ 140	$ 140	$ 72	$ 72	$ 72	$ 72	$ 72
20	Title 12	Genre 12	500	500					$ 58	$ 58	$ 58	$ 58	$ 58	$ 58	$ 30	$ 30	$ 30	$ 30	$ 30
21	Title 13	Genre 13	1,200	1,200					$ 140	$ 140	$ 140	$ 140	$ 140	$ 140	$ 72	$ 72	$ 72	$ 72	$ 72
22	Title 14	Genre 14	925	925					$ 108	$ 108	$ 108	$ 108	$ 108	$ 108	$ 56	$ 56	$ 56	$ 56	$ 56
23	Title 15	Genre 15	452	452					$ 53	$ 53	$ 53	$ 53	$ 53	$ 53	$ 27	$ 27	$ 27	$ 27	$ 27
24	Title 16	Genre 16	3,000	3,000															$ 900	$ 1,500	$ 300	$ 300
25		Total	8,027	8,027
Sheet3

Sheet2 Report (Expected Results)

Sample Table - Dates Grid.xlsx
	A	B	C	D
1	Title	Genre	Caluclated Amount	Date
2	Title 1	Genre 1	$ -	FY19 Q1
3	Title 1	Genre 1	$ -	FY19 Q2
4	Title 1	Genre 1	$ -	FY19 Q2
5	Title 1	Genre 1	$ -	FY19 Q2
6	Title 1	Genre 1	$ -	FY19 Q3
7	Title 1	Genre 1	$ -	FY19 Q3
8	Title 1	Genre 1	$ -	FY19 Q3
9	Title 1	Genre 1	$ -	FY19 Q4
10	Title 1	Genre 1	$ -	FY19 Q4
11	Title 1	Genre 1	$ -	FY19 Q4
12	Title 1	Genre 1	$ -	FY20 Q1
13	Title 2	Genre 2	$ 87.50	FY19 Q1
14	Title 2	Genre 2	$ 87.50	FY19 Q2
15	Title 2	Genre 2	$ 87.50	FY19 Q2
16	Title 2	Genre 2	$ 87.50	FY19 Q2
17	Title 2	Genre 2	$ 87.50	FY19 Q3
18	Title 2	Genre 2	$ 87.50	FY19 Q3
19	Title 2	Genre 2	$ 45.00	FY19 Q3
20	Title 2	Genre 2	$ 45.00	FY19 Q4
21	Title 2	Genre 2	$ 45.00	FY19 Q4
22	Title 2	Genre 2	$ 45.00	FY19 Q4
23	Title 2	Genre 2	$ 45.00	FY20 Q1
24	Title 3	Genre 3	$ 140.00	FY19 Q1
25	Title 3	Genre 3	$ 140.00	FY19 Q2
26	Title 3	Genre 3	$ 140.00	FY19 Q2
27	Title 3	Genre 3	$ 140.00	FY19 Q2
28	Title 3	Genre 3	$ 140.00	FY19 Q3
29	Title 3	Genre 3	$ 140.00	FY19 Q3
30	Title 3	Genre 3	$ 72.00	FY19 Q3
31	Title 3	Genre 3	$ 72.00	FY19 Q4
32	Title 3	Genre 3	$ 72.00	FY19 Q4
33	Title 3	Genre 3	$ 72.00	FY19 Q4
34	Title 3	Genre 3	$ 72.00	FY20 Q1
Sheet2

 

[DanteAmor]

I was hoping the code would be easy to manipulate to my actual layout for my spreadsheet but it is much more complex then what I am used to.

Here the updated code with your data provided.
In the code I put some comments to explain it.

Sub Creating_report()
  Dim sh1 As Worksheet, a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
  
  Set sh1 = Sheets("Sheet1")
  lr = sh1.Range("O" & Rows.Count).End(3).Row     'last row of column O
  lc = sh1.Cells(2, Columns.Count).End(1).Column  'last column of row 2
  
  'Load in memory all data from cell O1 and to the last cell with data
  a = sh1.Range("O1", sh1.Cells(lr, lc)).Value2
  
  'Calculate an output matrix (1 to rows, 1 to columns)
  'the number of rows will be equal to the number of cells from cell O1 to the last cell
  '(surely there are fewer cells with data, but it is a calculation to size the output matrix)
  'With 4 columns
  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 4)
  
  For i = 7 To UBound(a, 1)      '7 initial row
    If a(i, 1) <> "" Then
      For j = 6 To UBound(a, 2)  '4 initial column, 1 is column O, 2 column P, ... 6 column T
        If a(i, j) <> "" Then
          k = k + 1
          b(k, 1) = a(i, 1) 'Title
          b(k, 2) = a(i, 2) 'Genre
          b(k, 3) = a(i, j) 'Amount
          b(k, 4) = a(2, j) 'Date
        End If
      Next j
    End If
  Next i
  
  'The process puts the array in the cells, starting in cell A2
  Sheets("Sheet2").Range("A2").Resize(k, 4).Value = b
End Sub

 

[Johnny Thunder]

@DanteAmor I started on a new project that is very similar to this one with values in different cells but unfortunately I wasn't able to adapt this code to work on the other project. If you have time, do you mind checking out the other post.

VBA Help - Creating Data Table from Dashboard

Hello All, I have a dashboard that I need to extract data from to turn into a vertical style report to be able to run pivots and other things with the data. From the dashboard, I need to grab the headers from Cells (A13:I13) and then get the details starting at row 15. For any Series value...

www.mrexcel.com

 

[DanteAmor]

The code in post #5 worked for you?

 

[Johnny Thunder]

Yes sir! It worked great for that last project. I tried to take your commented sections and update it to fit my new request but I don't know enough about array type of ranges to modify.

Thanks again for all the help in the past. your solutions have always been great!

 

[DanteAmor]

Again with pleasure. Thanks for the feedback

 

[Johnny Thunder]

@DanteAmor I started on a new project that is very similar to this one with values in different cells but unfortunately I wasn't able to adapt this code to work on the other project. If you have time, do you mind checking out the other post.

VBA Help - Creating Data Table from Dashboard

Hello All, I have a dashboard that I need to extract data from to turn into a vertical style report to be able to run pivots and other things with the data. From the dashboard, I need to grab the headers from Cells (A13:I13) and then get the details starting at row 15. For any Series value...

www.mrexcel.com

So, are you able to help out with modifying the code used in this post to the new project?