0

From this data: enter image description here

I want to produce output like this:

enter image description here

Header is already made, but rest using a formula or vba.
Maybe get a position of cell where value > 0 and offset it or use xlUp/xlLef?
But then what if there are more data to left of fruits and above the dates?

Community
  • 1
  • 1
ggmkp
  • 665
  • 3
  • 16
  • 27

1 Answers1

0

Something like this; manually select table and then run macro ... it will prompt for destination and write it out the list. Ignore's table cells that are blank.

Sub TableToList()

    Dim rngSelection As Range
    Dim rngDestination As Range
    Dim lngRow As Long
    Dim lngColumn As Long
    Dim lngCounter As Long

    ' Ensure that the selection is at least 2 rows and 2 columns
    Set rngSelection = Application.Selection
    If rngSelection.Rows.Count < 2 Or rngSelection.Columns.Count < 2 Then
        MsgBox "Selected data must have a minimum of two rows and two columns.", vbInformation
        End
    End If

    ' Ask the user to select the cell for where the list is to be written
    Set rngDestination = Application.InputBox(prompt:="Select a destination cell:", Type:=8)

    ' Loop through the table and write out the list.
    lngCounter = 0
    For lngRow = 2 To rngSelection.Rows.Count
        For lngColumn = 2 To rngSelection.Columns.Count
            If ActiveCell.Cells(lngRow, lngColumn) <> "" Then
                rngDestination.Offset(lngCounter, 0) = ActiveCell.Cells(lngRow, 1)
                rngDestination.Offset(lngCounter, 1) = ActiveCell.Cells(1, lngColumn)
                rngDestination.Offset(lngCounter, 2) = ActiveCell.Cells(lngRow, lngColumn)
                lngCounter = lngCounter + 1
            End If
        Next
    Next

End Sub
TechnoDabbler
  • 1,245
  • 1
  • 6
  • 12