VBA help needed. How to extract values from a table to itemised as 3 column data

[Brandonfromsingapore]

Hello Forum,
I was wondering if you can help me with a vba code to extract values from a table like this to multiple rows of 3 columns only.

Name of Students	Apples	Lemon	Oranges	Pineapple	Strawberry	Grape	Lime	Coconut
Peter	4			2	1
John
Derrick			3				1
Stuart		7
Paul		7
Mary
Jim
Susan		9						2
Dorothy
Rick	1						1
Michael

<tbody>
</tbody>

Desired outcome is this

Peter	Apples	4
Peter	Pineapple	2
Peter	Strawberry	1
Derrick	Oranges	3
Derrick	Lime	1
Stuart	Lemon	7
Paul	Lemon	7
Susan	Lemon	9
Susan	Coconut	2
The logic continues

<tbody>
</tbody>

Thank you!

 

[Comfy]

Sub Transpose()
Dim LastRow As Long, LastCol As Long, i As Long, j As Long, output As Long
Dim Student As String


LastCol = Cells(1, 1).End(xlToRight).Column
LastRow = Cells(1, 1).End(xlDown).Row
output = LastRow + 2


For i = 2 To LastRow
Student = Cells(i, 1).Value
    For j = 2 To LastCol
        If Cells(i, j).Value <> "" Then Cells(output, 1).Value = Student: Cells(output, 2).Value = Cells(1, j).Value: Cells(output, 3).Value = Cells(i, j).Value: output = output + 1
    Next j
Next i


End Sub

 

[Andrew Poulsom]

Look here:

Spreadsheet Page Excel Tips: Creating A Database Table From A Summary Table

 

[Brandonfromsingapore]

Hello Comfy! Good morning! Thank you so so much for helping me. I tried the codes and it worked very well! I want to ask for your help to modify this a little bit as I saw that the results are displayed in the same sheet and at the bottom. Because I need to use the results to upload to a database, would it be possible to have the result be done on a Sheet2 starting from cell A1? And then the final step would be then to delete this Sheet1 once the steps are complete? Then sheet2 (the results) would remain as the only sheet on this workbook.

This would be what I hope to accomplished! Thank you!

 

[Brandonfromsingapore]

Hello Andrew
Good morning. Thank you for your help! I was able to visit the URL link and then I saw the VBA codes. I tried the VBA codes but the results were that even the blank entries (ie there are no values) would be displayed as a row. I have many empty rows where the student don't have any fruits and I want to delete this row. I only need rows to show where there are actual numbers.

I was looking elsewhere in the forum to see if I could get a code to search for column C in the results and then to delete the whole row if there is nothing in column C. This would then trim and eliminate the empty data rows. However, because the results are shown in a dynamic cell (the VBA code prompt and ask the use to select the cell to start the result display area), I wasn't able to effectively use the code below.
It doesn't work well

Sub test()On Error Resume NextWith Sheets1 .Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.DeleteEnd WithEnd Sub</pre>

 

[Comfy]

would it be possible to have the result be done on a Sheet2 starting from cell A1? And then the final step would be then to delete this Sheet1 once the steps are complete? Then sheet2 (the results) would remain as the only sheet on this workbook.

updated.

Sub Transpose()
Dim LastRow As Long, LastCol As Long, i As Long, j As Long, output As Long
Dim Student As String
Dim ws1 As Worksheet, ws2 As Worksheet


Application.DisplayAlerts = False


Set ws1 = ActiveSheet
Set ws2 = Sheets.Add


LastCol = ws1.Cells(1, 1).End(xlToRight).Column
LastRow = ws1.Cells(1, 1).End(xlDown).Row
output = 1


For i = 2 To LastRow
Student = ws1.Cells(i, 1).Value
    For j = 2 To LastCol
        If ws1.Cells(i, j).Value <> "" Then ws2.Cells(output, 1).Value = Student: ws2.Cells(output, 2).Value = ws1.Cells(1, j).Value: ws2.Cells(output, 3).Value = ws1.Cells(i, j).Value: output = output + 1
    Next j
Next i


ws1.Delete


Application.DisplayAlerts = True
End Sub

 

[Brandonfromsingapore]

Hello Comfy,
thank you. It works very well!

updated.

Sub Transpose()
Dim LastRow As Long, LastCol As Long, i As Long, j As Long, output As Long
Dim Student As String
Dim ws1 As Worksheet, ws2 As Worksheet


Application.DisplayAlerts = False


Set ws1 = ActiveSheet
Set ws2 = Sheets.Add


LastCol = ws1.Cells(1, 1).End(xlToRight).Column
LastRow = ws1.Cells(1, 1).End(xlDown).Row
output = 1


For i = 2 To LastRow
Student = ws1.Cells(i, 1).Value
    For j = 2 To LastCol
        If ws1.Cells(i, j).Value <> "" Then ws2.Cells(output, 1).Value = Student: ws2.Cells(output, 2).Value = ws1.Cells(1, j).Value: ws2.Cells(output, 3).Value = ws1.Cells(i, j).Value: output = output + 1
    Next j
Next i


ws1.Delete


Application.DisplayAlerts = True
End Sub