Data from across row to individual entries in another sheet

Question

Hi everyone

I have tried googling a way to do this but have not managed to find a way around.

My data is sorted out like below:

	Apple	Pear	Peach
Harry	3
Andrew		2	1
William	1
Philip	2	3

 

 

I need to then report in another sheet where each "coordinate" presents a row of data.

 

Fruit	Person	Amount
Apple	Harry	3
Pear	Andrew	2
Peach	Andrew	1

 

I need the macro skip over the blanks, but keep reporting down as far the Column A goes in the original sheet, but cannot determine how many columns across.

 

I don't even know how and where to start :( Would appreciate any insight into this.

Answer 1

Try this code

Sub Test()
    Dim a, b, i As Long, j As Long, k As Long

    a = Sheets("Sheet1").Range("A1").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * 3, 1 To 3)

    For i = 2 To UBound(a, 1)
        For k = 2 To UBound(a, 2)
            If a(i, k) <> "" Then
                j = j + 1
                b(j, 1) = a(1, k)
                b(j, 2) = a(i, 1)
                b(j, 3) = a(i, k)
            End If
        Next k
    Next i

    With Sheets("Sheet1").Range("I1")
        .Resize(, UBound(b, 2)).Value = Array("Fruit", "Person", "Amount")
        .Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
    End With
End Sub

 

I have played around to make a public procedure for the code

You can try this code too

Sub Test_RowsMatrix()
    With Worksheets("Sheet1")
        RowsMatrix .Range("A1"), .Range("I1"), Array("Fruit", "Person", "Amount"), 3
    End With
End Sub

Sub RowsMatrix(sourceCel As Range, tagretCel As Range, aHeaders As Variant, colNum As Long)
    Dim a, b, i&, j&, k&, x&

    a = sourceCel.CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * colNum, 1 To UBound(aHeaders) + 1)

    For i = 2 To UBound(a, 1)
        For k = 2 To UBound(a, 2)
            If a(i, k) <> "" Then
                j = j + 1
                
                For x = 1 To colNum
                    b(j, x) = a(IIf(x = 1, 1, i), IIf(x = 2, 1, k))
                Next x
            End If
        Next k
    Next i

    With tagretCel
        .Resize(, UBound(b, 2)).Value = aHeaders
        .Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
    End With
End Sub

 

Comments

Thank you soooooo much for this! This has really helped me with my work.

---

I've just hit a second hurdle.

Is there a way to get excel to get a cell value as the destination cell and the next cell as the value?

Notify	Details	Cell	QTY	Cell	Supplier
Yes	Apples	A2	5	B2	ABC
Delay	Pears
Yes	Peachers	A3	3	B3	DEF

Is it possible to copy the value of D2 here (ie 5) to cell A2 in sheet2? and then here E2 (ie ABC) to cell B2 and keep going until there is none left?

---

I think the structure is different. Can you give us the final desired output in sheet2 based on the input table you posted in your comment?

---

Thank you so much for your assistance!

This is where we start from: (slight change from the one above because I made a mistake)

Notify	Details	Cell	Qty	Cell	Supplier	Cell	Qty	Cell	Supplier
Yes	Apples	B2	5	C2	ABC	B3	3	C3	DEF
Delay	Pears
Yes	Peaches	B4	4	C4	XYZ

To

Details	Qty	Supplier
Apples	5	ABC
Apples	3	DEF
Peaches	4	XYZ

So the cell reference is on the left of the value I want copied over :S

Answer 2

With the new structure you can use loops in simple way to reach your goal

Try this code

Sub Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim lr          As Long
    Dim lc          As Long
    Dim r           As Long
    Dim c           As Long
    Dim m           As Long
    
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Set sh = ThisWorkbook.Worksheets("Sheet2")
        lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
        lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        sh.Cells.ClearContents
        sh.Range("A1").Resize(, 3).Value = Array("Details", "Qty", "Supplier")
        
        For r = 2 To lr
            For c = 4 To lc Step 4
                If ws.Cells(r, c).Value <> "" Then
                    m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    sh.Cells(m, 1).Value = ws.Cells(r, 2).Value
                    sh.Cells(m, 2).Value = ws.Cells(r, c).Value
                    sh.Cells(m, 3).Value = ws.Cells(r, c).Offset(, 2).Value
                End If
            Next c
        Next r
    Application.ScreenUpdating = True
End Sub

 

Comments

Thanks again for such a prompt response.

It appears to have done exactly that.

If the Notify Yes / No / Delay is in another column further right, where would I modify that rule?

I tried changing B2 to C8 hoping that it might move the 5 to cell reference 8 but the output had the 5 in the same spot ie still existing happily in B2.

Also, if I have more than the 3, can I just add on?

 sh.Cells(m, 3).Value = ws.Cells(r, c).Value
 sh.Cells(m, 4).Value = ws.Cells(r, c).Value
 sh.Cells(m, 5).Value = ws.Cells(r, c).Value

Thanks again!

---

And what about "Apples" for example, there is reference for a range to put in ..

I see the issue is unlogical a little ..

---

I think I see the problem now.

No wonder no one wants to do the job... and have been doing it the manual way for years.

---

Try this although it is not logical for me

Sub Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim lr          As Long
    Dim lc          As Long
    Dim r           As Long
    Dim c           As Long
    Dim m           As Long
    
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Set sh = ThisWorkbook.Worksheets("Sheet2")
        lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
        lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        sh.Cells.ClearContents
        sh.Range("A1").Resize(, 3).Value = Array("Details", "Qty", "Supplier")
        
        For r = 2 To lr
            For c = 4 To lc Step 4
                If ws.Cells(r, c).Value <> "" Then
                    m = Range(ws.Cells(r, c).Offset(, -1).Value).Row
                    sh.Cells(m, 1).Value = ws.Cells(r, 2).Value
                    sh.Range(ws.Cells(r, c).Offset(, -1).Value).Value = ws.Cells(r, c).Value
                    sh.Range(ws.Cells(r, c).Offset(, 1).Value).Value = ws.Cells(r, c).Offset(, 2).Value
                End If
            Next c
        Next r
    Application.ScreenUpdating = True
End Sub