Hallo Andreas,
ist es nicht einfacher, die Tabelle in die folgende Form umzuwandeln und dann Auswertung als Pivottabellenberichte zu erstellen?
No. Date Time Sender Empfänger Typ Datum Zeit
1 070118 0842 Prof. G. Prof. G. x 18.01.2007 8:42
1 070118 0842 Prof. G. Simon 1 18.01.2007 8:42
2 070118 0937 Simon Prof. G. 1 18.01.2007 9:37
2 070118 0937 Simon Simon x 18.01.2007 9:37
3 070213 0340 Simon Prof. G. 1 13.02.2007 3:40
3 070213 0340 Simon Simon x 13.02.2007 3:40
Das Entsprechende makro, das die EMAIL_GEN-Daten in ein anderes Blatt ausgibt sieht wie folgt aus.
Sub AuswertungFuellen()
Dim wksGen As Worksheet
Dim wksAus As Worksheet
Dim lngZeile As Long, lngSpalte As Long, lngZeileA As Long
Set wksGen = Worksheets("EMAIL_GEN")
Set wksAus = Worksheets("Auswerten")
With wksAus
.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown).Offset(0, 7)).ClearContents
End With
With wksGen
lngZeileA = 1
For lngZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
For lngSpalte = 5 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If .Cells(lngZeile, lngSpalte) "" Then
lngZeileA = lngZeileA + 1
wksAus.Cells(lngZeileA, 1) = .Cells(lngZeile, 1) 'No
wksAus.Cells(lngZeileA, 2) = .Cells(lngZeile, 2) 'Date
wksAus.Cells(lngZeileA, 3) = .Cells(lngZeile, 3) 'Time
wksAus.Cells(lngZeileA, 4) = .Cells(lngZeile, 4) 'Sender
wksAus.Cells(lngZeileA, 5) = .Cells(1, lngSpalte) 'Empfänger
wksAus.Cells(lngZeileA, 6) = .Cells(lngZeile, lngSpalte) 'Type
wksAus.Cells(lngZeileA, 7) = fncDatum(.Cells(lngZeile, 2)) 'Datum Excelformat
wksAus.Cells(lngZeileA, 8) = fncZeit(.Cells(lngZeile, 3)) 'Zeit Excelformat
End If
Next
Next
End With
End Sub
Function fncDatum(strDatum As String) As Date
If IsNumeric(strDatum) Then
fncDatum = CDate(Right(strDatum, 2) & "." & Mid(strDatum, 3, 2) & "." & Mid(strDatum, 1, 2)) _
End If
End Function
Function fncZeit(strZeit As String) As Date
If IsNumeric(strZeit) Then
fncZeit = CDate(Mid(strZeit, 1, 2) & ":" & Mid(strZeit, 3, 2) & ":00")
End If
End Function
Ein Makro für deine Matrizen sieht ähnlich aus. Auf Basis des Sender und Empfängernamens muss du dann in jeder Matize die zugehörige Zeile und Spalte ermitteln und die Zelle entsprechend ausfüllen. Nachfolgend ein Beispiel. Die Bedingungen wann welcher Wert in die Zielzelle eingetragen werden soll muss du anpassen.
Sub C_01_Fuellen()
Dim wksGen As Worksheet
Dim wksAus As Worksheet
Dim lngZeile As Long, lngSpalte As Long
Dim varSender, varEmpfaenger
Dim ZelleSender As Range, ZelleEmpf As Range, ZelleZiel As Range
Set wksGen = Worksheets("EMAIL_GEN")
Set wksAus = Worksheets("C_01")
With wksAus
'vorhandene Einträge in Matrix löschen
.Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Cells(1, .Columns.Count).End(xlToLeft).Column)).ClearContents
End With
With wksGen
For lngZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
For lngSpalte = 5 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If .Cells(lngZeile, lngSpalte) "" Then
varSender = .Cells(lngZeile, 4) 'Sender
varEmpfaenger = .Cells(1, lngSpalte) 'Empfänger
With wksAus
'Sender in Spalte A der Matrix suchen
Set ZelleSender = .Columns(1).Find(What:=varSender, LookIn:=xlValues, _
lookat:=xlWhole)
'Empfänger in Zeile 1 der Matrix suchen
Set ZelleEmpf = .Rows(1).Find(What:=varEmpfaenger, LookIn:=xlValues, _
lookat:=xlWhole)
If Not ZelleSender Is Nothing And Not ZelleEmpf Is Nothing Then
'Zielzelle setzen
Set ZelleZiel = .Cells(ZelleSender.Row, ZelleEmpf.Column)
'Daten in Zielzelle eintragen
Select Case wksGen.Cells(lngZeile, lngSpalte).Value
Case "1"
ZelleZiel = ZelleZiel + 1
Case "x", "X"
Case Else
'do nothing
End Select
End If
Set ZelleSender = Nothing
Set ZelleEmpf = Nothing
Set ZelleZiel = Nothing
End With
End If
Next
Next
End With
Set wksGen = Nothing
Set wksAus = Nothing
End Sub
Gruß
Franz