Das dürfte möglich sein... aber zuerst ein mal etwas in anderer Sache. ;)

Es ist nicht die feine Art in einem fremden Thema mit einem neuen hereinzuschneien (auch wenn sie sich ähneln). Bitte beim nächsten mal also ein neues eröffnen. So bleiben die Themen innerhalb übersichtlich und man wird nicht mittendrin abgelenkt. ;)

So, nun zur Frage:

Option Explicit

'Konstanten zum "anspringen" der Spalten, rel. zur TYPE-Spalte (in Datenquelle)
Private Const C_OFFSET_YEAR& = 1
Private Const C_OFFSET_VALUES& = 2
Private Const C_OFFSET_NUMBERS& = 3

'Fehler - Konstanten
Private Const C_ERR_TYPENAME_NOT_FOUND& = vbObjectError + &H1
Private Const C_ERR_TOMANYHITS& = vbObjectError + &H2
Private Const C_ERR_NODATE& = vbObjectError + &H3

Sub Transp()
  
  Dim wksD          As Excel.Worksheet
  Dim rngTypeD      As Excel.Range
  Dim rngYearD      As Excel.Range
  Dim rngCellD      As Excel.Range
  Dim rngCellS      As Excel.Range
  Dim strErrDescr   As String
  Dim lngErrNum     As Long
  
  Set wksD = Tabelle2
  
  For Each rngTypeD In wksD.Range(wksD.Range("A2"), wksD.Columns("A").End(xlDown)).Cells
    For Each rngYearD In wksD.Rows(1).SpecialCells(xlCellTypeConstants, xlNumbers).Cells
      
      Set rngCellD = wksD.Cells(rngTypeD.Row, rngYearD.Column)
      rngCellD.Clear 'lösche Inhalt, Kommentar, Format, ... kurz: Alles
      
      If FetchData(Typename:=Trim$(rngTypeD.Text), _
                    DataType:=Trim$(rngTypeD.Offset(, 1).Text), _
                    Year:=Trim$(rngYearD.Text), _
                    DateCell:=rngCellS, _
                    ErrNumber:=lngErrNum, _
                    ErrDescription:=strErrDescr) _
      Then
        rngCellD.Value = rngCellS.Value
        rngCellD.Hyperlinks.Add rngCellD, Address:="", SubAddress:=rngCellS.Address(External:=True), ScreenTip:="Gehe zu Quelle..."
        rngCellD.ClearFormats 'wir entfernen mal die Hyperlink-Formatierung (der Hyperlink selbst bleibt bestehen)
        
      ElseIf lngErrNum = C_ERR_NODATE Then
      'hier wurde kein passender Eintrag gefunden
        rngCellD.Value = 0
        
      Else
      'Wenn ein Fehler auftrat, wird dies durch "die-Farbe-der-Gefahr" kennlich gemacht ... kurz: ROT
        rngCellD.Font.Color = vbRed
        rngCellD.Font.Bold = True
        rngCellD.Value = CVErr(xlErrNA)
        rngCellD.AddComment strErrDescr 'Fehlerbeschreibung als Zellen-Kommentar
      End If
      
    Next
  Next
  
  'Kleine Nachricht auf Bildschirm ausgeben.
  '(Damit der Nutzer weiß wann er wieder die Maus zu befummeln hat) ;)
  Call MsgBox("Fertig", vbInformation)
  
End Sub

Private Function FetchData( _
    ByVal Typename As String, ByVal DataType As String, ByVal Year As String, _
    ByRef DateCell As Excel.Range, _
    ByRef ErrNumber As Long, _
    ByRef ErrDescription As String _
) As Boolean
  
  'Korrektur Data Type
  If StrComp(DataType, "Value", vbTextCompare) = 0 Then
    DataType = "Values"
  ElseIf StrComp(DataType, "Number", vbTextCompare) = 0 Then
    DataType = "Numbers"
  End If
  
  Dim wks           As Excel.Worksheet
  Dim rngType       As Excel.Range
  Dim rngDataType   As Excel.Range
  Dim rngYear       As Excel.Range
  Dim rng           As Excel.Range
  Dim str           As String
  
  Set wks = Tabelle1 'Datenquelle
  
  'zuerst suchen wir nach allen passenden Einträgen in der Spalte TYPE
  With wks.Columns("A")
    Set rng = .Find(Typename, LookIn:=xlValues, LookAt:=xlWhole)
    If Not rng Is Nothing Then
      str = rng.Address
      Do
        If Not rngType Is Nothing Then
          Set rngType = Union(rngType, rng)
        Else
          Set rngType = rng
        End If
        Set rng = .FindNext(rng)
      Loop While rng.Address <> str
    End If
  End With
  
  If rngType Is Nothing Then
    ErrNumber = C_ERR_TYPENAME_NOT_FOUND
    ErrDescription = "Der Typ '" & Typename & "' wurde im Arbeitsblatt '" & wks.Name & "' nicht gefunden."
    Exit Function
  End If
  
  'nun suchen wir innerhalb der gefundenen Einträge, nach dem passenden Jahr
  With rngType.Offset(, C_OFFSET_YEAR)
    Set rng = .Find(Year, LookIn:=xlValues, LookAt:=xlWhole)
    If Not rng Is Nothing Then
      str = rng.Address
      Do
        If Not rngYear Is Nothing Then
          Set rngYear = Union(rngYear, rng)
        Else
          Set rngYear = rng
        End If
        Set rng = .FindNext(rng)
      Loop While rng.Address <> str
    End If
  End With
  
  If rngYear Is Nothing Then
  'kein Eintrag mit dem vorgegebenen Jahr gefunden
    ErrNumber = C_ERR_NODATE
    ErrDescription = "Für den Typ '" & Typename & "' existiert im Arbeitsblatt '" & wks.Name & "' kein Eintrag."
    Exit Function
  ElseIf rngYear.Cells.Count > 1 Then
  'mehr als ein Eintrag mit dem vorgegebenen Jahr gefunden
    ErrNumber = C_ERR_TOMANYHITS
    ErrDescription = "Zu viele Einträge des Typs '" & Typename & "' in Arbeitsblatt '" & wks.Name & "' für das Jahr " & Year & " gefunden (" & rngYear.Cells.Count & " Treffer)."
    Exit Function
  End If
  
  'auf einen Eintrag reduzieren
  Set rngType = Intersect(rngType, rngYear.Offset(, -C_OFFSET_YEAR))
  
  'nun gilt es nur noch den Data Type zu berücksichtigen
  If wks.Range("A1").Offset(, C_OFFSET_VALUES).Text = DataType Then
    Set DateCell = rngType.Offset(, C_OFFSET_VALUES)
  ElseIf wks.Range("A1").Offset(, C_OFFSET_NUMBERS).Text = DataType Then
    Set DateCell = rngType.Offset(, C_OFFSET_NUMBERS)
  Else
    ErrDescription = "Data Type '" & DataType & "' konnte in Arbeitsblatt '" & wks.Name & "' nicht gefunden werden."
    Exit Function
  End If
  
  FetchData = True
  
End Function

Gruß, Trägheit