how to get column name if that column has value for each row in excel

259 Views Asked by At

Source The source picture has names in the 1st column and the 1st row has dated. There are values for each date column. Need to get Dates and their values for each name if there is a value for a particular date.

Output

1

There are 1 best solutions below

4
VBasic2008 On

A Simple Unpivot

enter image description here

Sub UnpivotRCV()
  
    ' Define constants.
    Const SRC_NAME As String = "Sheet1"
    Const DST_NAME As String = "Sheet2"
    Const DST_FIRST_CELL As String = "A2"
    Const DST_COLUMNS_COUNT As Long = 3 ' fixed
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source range.
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim scCount As Long: scCount = srg.Columns.Count
    
    ' Write the values from the source range to the source array.
    Dim sData: sData = srg.Value
    
    ' Define the destination array.
    Dim drCount As Long: drCount = (srCount - 1) * (scCount - 1)
    Dim dData(): ReDim dData(1 To drCount, 1 To DST_COLUMNS_COUNT)
    
    Dim sr As Long, sc As Long, dr As Long
    
    ' Return the unpivoted values from the source array
    ' in the destination array.
    For sr = 2 To srCount
        For sc = 2 To scCount
            If Len(CStr(sData(sr, sc))) > 0 Then
                dr = dr + 1
                dData(dr, 1) = sData(sr, 1) ' row label
                dData(dr, 2) = sData(1, sc) ' column label
                dData(dr, 3) = sData(sr, sc) ' value
            End If
        Next sc
    Next sr
    
    ' Reference the destination range.
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
    Dim drg As Range: Set drg = dfCell.Resize(dr, DST_COLUMNS_COUNT)
    
    ' Write, clear and autfit.
    drg.Value = dData
    drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).ClearContents
    drg.EntireColumn.AutoFit
    
    MsgBox "Data unpivoted.", vbInformation
    
End Sub