VBA insert variable number of rows and copy data

[kweaver]

I have data that looks like the following:

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	Name	Dept	Head3	Head4	Head5	Head6	Head7	Head8	Head9	Head10	Head11	Head12	Head13	Head14	Head15	Reg	OT	DT	other1	other2	other3	other4	other5
2	Kevin	AAA	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	0	0	6	0	0	0	0	0
3	Mary	BBB	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	8	0	5	0	0	3	0	0
4	John	CCC	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	0	5	0	0	0	0	0	0
5	Willilam	AAA	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	0	0	0	0	0	0	9	0
6	Susan	DDD	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	5	0	0	0	0	0	0	0.5
7	Chelsea	AAA	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	10	6	1	0	0.5	0	0	0
Sheet1

Below each row I need to insert a number of rows based on how many values from P to W are greater than 0.
Then, replicate the rows from columns A to O and show the column headings from P1 to W1 and the corresponding non-zero data so that the result looks like the following:

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
10	Name	Dept	Head3	Head4	Head5	Head6	Head7	Head8	Head9	Head10	Head11	Head12	Head13	Head14	Head15	Result1	Result2
11	Kevin	AAA	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	6	DT
12	Mary	BBB	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	8	Reg
13	Mary	BBB	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	5	DT
14	Mary	BBB	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	3	other3
15	John	CCC	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	5	OT
16	Willilam	AAA	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	9	other4
17	Susan	DDD	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	5	Reg
18	Susan	DDD	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	0.5	other5
19	Chelsea	AAA	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	10	Reg
20	Chelsea	AAA	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	6	OT
21	Chelsea	AAA	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	1	DT
22	Chelsea	AAA	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	Other_Data	0.5	other2
Sheet1

In other words, I want to show only the non-zero values from each row's columns P through W, and indicate where they came from (Row 1 headings in P through W)
And duplicate the data (e.g. Mary's columns A through O are duplicaded twice because there are three non-zero values in P through W).

SIGH. Hope that's fairly clear.

It should be done in VBA and the resulting array of data can be on a new sheet.

 

[Alex Blakenburg]

I would probably have used Power Query to do this.

If you are happy with a slightly long-winded solution try this.
I am outputting to Sheet2 and as it stands the sheet needs to exist.

Sub TransposeData()

    Dim srcRng As Range
    Dim arrSrc As Variant
    Dim outRng As Range
    Dim srcSht As Worksheet
    Dim outSht As Worksheet
    Dim iRow As Long, iCol As Long, iOutRow As Long
    Dim iLastCol As Long, iFixedCol As Long, iValCol As Long, j As Long
    Dim arrOut As Variant
    
    Set srcSht = Worksheets("Sheet1")               ' <---- Change Sheet name as required
    Set outSht = Worksheets("Sheet2")               ' <---- Change Sheet name as required
    Set srcRng = srcSht.Range("A1").CurrentRegion
    arrSrc = srcRng
    iLastCol = srcRng.Columns.Count
    iFixedCol = 15
    iValCol = iLastCol - iFixedCol
    
    ReDim arrOut(1 To iFixedCol * iValCol, 1 To iFixedCol + 2)
    iOutRow = 0
    
    ' Read source data
    For iRow = 2 To UBound(arrSrc)
        ' Loop through the Value Columns
        For iCol = iFixedCol + 1 To iLastCol
            ' Capture non-Zero value columns
            If arrSrc(iRow, iCol) <> 0 Then
                iOutRow = iOutRow + 1
                For j = 1 To iFixedCol
                    arrOut(iOutRow, j) = arrSrc(iRow, j)
                Next j
                arrOut(iOutRow, iFixedCol + 1) = arrSrc(iRow, iCol)
                arrOut(iOutRow, iFixedCol + 2) = arrSrc(1, iCol)
            End If
        Next iCol
    Next iRow
    
    ' Output non-zero rows
    outSht.Range("A2").Resize(UBound(arrOut, 1), UBound(arrOut, 2)) = arrOut
    ' Output the headings
    For j = 1 To iFixedCol
        outSht.Cells(1, j) = arrSrc(1, j)
    Next j
    outSht.Cells(1, iFixedCol + 1) = "Result1"
    outSht.Cells(1, iFixedCol + 2) = "Result2"
 
End Sub

 

[kweaver]

THANK YOU for taking a shot at this.
I just started to examine and run it but got a "Subscript out of range" error here:

 

[kweaver]

Alex: it worked on the sample data I used in my OP, but not on the real data sheet.

In the real data there are some rows that have all zeros in P through W...does that make a difference?

 

[kweaver]

Alex: if this helps (didn't help me) this is the status at the error.

 

[Fluff]

How about

Sub kweaver()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, nc As Long
   
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * (UBound(Ary, 2) - 15), 1 To 17)
   
   For r = 2 To UBound(Ary)
      For c = 16 To UBound(Ary, 2)
         If Ary(r, c) > 0 Then
            nr = nr + 1
            For nc = 1 To 15
               Nary(nr, nc) = Ary(r, nc)
            Next nc
            Nary(nr, 16) = Ary(r, c)
            Nary(nr, 17) = Ary(1, c)
         End If
      Next c
   Next r
   With Sheets("Sheet2")
      .Range("A1:O1").Value = Sheets("Sheet1").Range("A1:O1").Value
      .Range("P1:Q1").Value = Array("Result1", "Result2")
      .Range("A2").Resize(nr, 17).Value = Nary
   End With
End Sub

 

[kweaver]

Thank you, Fluff. I'm installing and testing.

 

[kweaver]

Fluff...looks GREAT (of course). Thank you for your help again!!

 

[Fluff]

Glad we could help & thanks for the feedback.

 

[Alex Blakenburg]

Alex: if this helps (didn't help me) this is the status at the error.

I know Fluff has provided you with the solution but as a contributing member yourself, you can appreciate that once you buy into a question you like to get your own contribution to work.
So I really appreciate your excellent troubleshooting images in your post #6 and it did indeed help. The immediate window image showed me that when you had more rows my redim was using a static number of 120 whereas it should have expanded.
Fluff is using a Redim of Total Rows * Total Columns.
ReDim Nary(1 To UBound(Ary) * (UBound(Ary, 2) - 15), 1 To 17)
I was trying to keep it smaller with Total Rows * No of Value Columns. I suspect the extra empty space used in the more generic method doesn't matter much and allows the code to be used as a template.
My code should have been:
ReDim arrOut(1 To UBound(arrSrc) * iValCol, 1 To iFixedCol + 2)

I also noticed that Fluff used Value2 rather than Value and for this sort of thing Value2 is probably better.

I tried to code it so that if you add more Value columns the code would work unchanged and if you change the number of fixed (columns of data to repeat) all you had to do was change this line. iFixedCol = 15

Once again thanks for the feedback.