Option Explicit
Private Const C_OFFSET_YEAR& = 1
Private Const C_OFFSET_VALUES& = 2
Private Const C_OFFSET_NUMBERS& = 3
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
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
ElseIf lngErrNum = C_ERR_NODATE Then
rngCellD.Value = 0
Else
rngCellD.Font.Color = vbRed
rngCellD.Font.Bold = True
rngCellD.Value = CVErr(xlErrNA)
rngCellD.AddComment strErrDescr
End If
Next
Next
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
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
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
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
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
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
Set rngType = Intersect(rngType, rngYear.Offset(, -C_OFFSET_YEAR))
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