If Statement with INDEX/MATCH to matched between two range of values in different sheet

A VBA Unpivot

• Copy the code into a standard module, e.g. Module1 of the workbook containing the two worksheets.
• Carefully adjust the values in the constants section.
• Both cell addresses refer to the first cells of the table headers.
• You should give PowerQuery a try. It will take a few minutes once you get a hang of it. And it has a ton of options.

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Unpivots a table range (has headers) to another worksheet.
' Calls:        'RefCurrentRegionBottomRight'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub UnPivotData()
    
    ' Source
    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "D4"
    Const scCount As Long = 22
    ' Destination
    Const dName As String = "Output"
    Const dFirstCellAddress As String = "A1"
    Dim dHeaders As Variant: dHeaders = VBA.Array("YEAR", "COMPANY", "WC01651")
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write from source range to source array.
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
    Dim srg As Range
    Set srg = RefCurrentRegionBottomRight(sfCell).Resize(, scCount)
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim sData As Variant: sData = srg.Value
    
    ' Size destination array.
    Dim dhUpper As Long: dhUpper = UBound(dHeaders)
    Dim drCount As Long: drCount = (srCount - 1) * (scCount - 1) + 1
    Dim dcCount As Long: dcCount = dhUpper + 1 ' zero- vs one-based
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    ' Write headers.
    Dim dh As Long
    For dh = 0 To dhUpper
        dData(1, dh + 1) = dHeaders(dh)
    Next dh
    
    Dim dr As Long: dr = 1 ' headers already written
    Dim sr As Long
    Dim sc As Long
    
    ' Write data ('body').
    For sr = 2 To srCount
        For sc = 2 To scCount
            dr = dr + 1 ' Note the 'PowerQuery' terms in parentheses: 
            dData(dr, 1) = sData(1, sc) ' write column labels (attributes)
            dData(dr, 2) = sData(sr, 1) ' write row labels
            dData(dr, 3) = sData(sr, sc) ' write values (values)
        Next sc
    Next sr
    
    ' Write from destination array to destination range.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
    Dim dcrg As Range
    Set dcrg = dfCell.Resize(dws.Rows.Count - dfCell.Row + 1, dcCount)
    dcrg.ClearContents
    Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
    drg.Value = dData
    
    MsgBox "Data transferred.", vbInformation
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a reference to the range starting with a given cell
'               and ending with the last cell of its Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegionBottomRight( _
    ByVal FirstCellRange As Range) _
As Range
    If FirstCellRange Is Nothing Then Exit Function
    With FirstCellRange.Cells(1).CurrentRegion
        Set RefCurrentRegionBottomRight = _
            FirstCellRange.Resize(.Row + .Rows.Count - FirstCellRange.Row, _
            .Column + .Columns.Count - FirstCellRange.Column)
    End With
End Function