Office: Datum-Matrix in übersichtliche Reihenfolge bringen

Hallo Zusammen,

ich habe eine Datum-Matrix (mehrere Spalten und Zeilen mit verschiedenen Terminen)
Ich möchte nun alle Daten in eine übersichtliche Kalenderstruktur bringen.

Anbei eine Beispiel Excel, so wie ich die Daten aufgebaut haben möchte.
Im Forum habe ich folgende Hilfe gefunden (Aus "Datums-Matrix" automatisch einen Kalender ers) , allerdings bekommen ich das nicht an meinen Fall angepasst.
Daher habe ich zur Erläuterung keine Formel verwendet, sondern nur die Daten hart rein getippt.

Ich hoffe jemand kann sich die Zeit nehmen, um mir zu helfen. Danke!

 

Das eine ist die Pest und das andere die Cholera.

Was richtig wäre, wären vier Spalten: Datum, Kunde, Produkt, Datums-Qualität.

Da gehst Du dann mit dem Filter drauf los, und zwar auf jede der vier Spalten.

Man könnte sich noch herablassen darauf, dass Deine beiden kranken Tabellen auch erzeugt würden. Aber nur auf Basis der gesunden.

 

Sicher hat lupo Recht mit seiner Bemerkung.
Dennoch habe ich mir getraut, eine VBA-Lösung für Dein Problem zu erstellen, schau mal:

Code:

Sub KalenderErstellen()
Const Zielzeile = 5 'Überschriftszeile Kalender
Const Quellzeile = 4 'Überschrift in Quelldaten
Const QName = "Quelldaten"
Dim Quelle As Object, Ziel As Object, DatRange As Object
Dim DatMin As Date, DatMax As Date, MyDat As Date
Dim zeile As Long, spalte As Long, erg As Variant, ErstADr As String
  Set Quelle = ThisWorkbook.Sheets(QName)
  Set DatRange = Quelle.Range("D:I")
  On Error Resume Next
  Set Ziel = ThisWorkbook.Sheets("Kalender")
  On Error GoTo 0
  If Ziel Is Nothing Then
    Set Ziel = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
  Else
    Ziel.UsedRange.ClearContents
  End If
  DatMin = WorksheetFunction.Min(DatRange)
  DatMax = WorksheetFunction.Max(DatRange)
  With Ziel
    .Name = "Kalender"
    zeile = Zielzeile
    .Cells(zeile, 1) = "Datum"
    .Cells(zeile, 2) = "Termine"
    zeile = zeile + 1
    MyDat = DatMin
    Do 'Kalender aufbauen
      .Cells(zeile, 1) = MyDat
      'Suche nach terminen mit diesem datum
      Set erg = DatRange.Find(what:=MyDat, lookat:=xlWhole)
      If Not erg Is Nothing Then
        spalte = 2
        ErstADr = erg.Address
        Do
          .Cells(zeile, spalte) = Quelle.Cells(erg.Row, 2) & "//" & Quelle.Cells(erg.Row, 3) & "//" & Quelle.Cells(Quellzeile, spalte + 2)
          spalte = spalte + 1
          Set erg = DatRange.FindNext(erg)
          If erg.Address = ErstADr Then Exit Do
        Loop
      End If
      zeile = zeile + 1
      MyDat = MyDat + 1
    Loop Until MyDat > DatMax
    .Columns("A:F").Columns.AutoFit
  End With
End Sub

Gruß der ALteDresdner

 

Hallo,

ich habe leider zu spät bemerkt, dass AlterDresdner bereits eine VBA-Lösung gezimmert hat. Damit meine Arbeit nicht gänzlich vergeblich war, möchte ich sie im Folgenden trotzdem herzeigen:

Code:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim lstZiel As ListObject, colZiel As ListColumn, colDatum As ListColumn
  Dim lstQuelle As ListObject, rwQuelle As ListRow, rngQuellkopf As Range
  Dim lngSpalte As Long, lngKunde As Long, lngBez As Long
  Dim strKundeBez As String, strEintrag As String
  Dim vDatum As Variant, rngDatum As Range
 
 'Teste die aktive Zelle "Target":
  With Target
     If .Count > 1 Then Exit Sub
     If .ListObject Is Nothing Then Exit Sub
     If .ListObject.Name <> "Tabelle2" Then Exit Sub                  '<== Zieltabelle-Name
     Set lstZiel = .ListObject
     Set colDatum = lstZiel.ListColumns("Datum")                      '<== Zieltabelle-Datumspalte
     If colDatum.Range.Cells(1).Address <> .Address Then Exit Sub
  End With
 
 '------------------------------------------------------
 'Die restlichen Makrozeilen werden nur dann ausgeführt,
 'wenn sich die aktive Zelle in der linken oberen Ecke der Zieltabelle 'Tabelle2' befindet
 '(in der Kopfzelle "Datum"):
 '------------------------------------------------------
 
 'Entferne in der Zieltabelle die Inhalte aus den Spalten "Termin1"..."TerminN"
 '(nur die Inhalte der Spalte "Datum" bleiben erhalten):
  For Each colZiel In lstZiel.ListColumns
    If colZiel.Index <> colDatum.Index Then colZiel.DataBodyRange.ClearContents
  Next colZiel
 
  Set lstQuelle = Worksheets("Quelldaten").ListObjects("Tabelle1")    '<== Quelltabelle
 
  With lstQuelle
    Set rngQuellkopf = .HeaderRowRange
    lngKunde = .ListColumns("Kunde").Index                            '<== Quelltabelle-Spalte "Kunde"
    lngBez = .ListColumns("Bezeichnung").Index                        '<== Quelltabelle-Spalte "Bezeichnung"
  End With
 
  'Durchlaufe die Quelltabelle zeilenweise:
  For Each rwQuelle In lstQuelle.ListRows
    With rwQuelle.Range
       'Entnimm den Kunden und die Bezeichnung aus den Zeilenzellen (benötigt für Zieltabelle-Eintrag)
       strKundeBez = .Cells(lngKunde).Value & "//" & .Cells(lngBez).Value & "//"
     
       'Überprüfe alle Zeilenzellen (außer Kunden/Bezeichnung-Spalte) der Quelltabelle, ob sie ein Datum enthalten:
       For lngSpalte = 1 To lstQuelle.ListColumns.Count
         Select Case lngSpalte
           Case lngKunde, lngBez: 'tue nichts, weil bereits in "strKundeBez" enthalten
           Case Else:
              vDatum = .Cells(lngSpalte).Value
              If Not IsEmpty(vDatum) Then
                 '-------------
                 'In einer Datumsspalte der Quelltabelle ist tatsächlich ein Datum enthalten.
                 'Vervollständige den Eintrag für die Zieltabelle:
                 strEintrag = strKundeBez & rngQuellkopf.Cells(lngSpalte).Value
                 '-------------
                 'Suche die passende Zeile der Zieltabelle und
                 'trage dort in die erste freie Zelle "strEintrag" ein:
                 Set rngDatum = colDatum.DataBodyRange.Find(What:=vDatum, LookIn:=xlValues, LookAt:=xlWhole)
                 If rngDatum Is Nothing Then
                    MsgBox Prompt:="Das Datum " & vDatum & " ist nicht in der Zieltabelle enthalten." & vbNewLine & _
                                   "Dieser Quelltabelleneintrag wird übergangen.", _
                           Title:="Quelldatum nicht in der Zieltabelle"
                 Else
                    Set rngDatum = rngDatum.Offset(0, 1) 'Zelle rechts der Datumszelle
                    Do Until IsEmpty(rngDatum.Value)     'Suche der ersten leeren Zelle in der Zieltabellen-Zeile
                       Set rngDatum = rngDatum.Offset(0, 1)
                    Loop
                    rngDatum.Value = strEintrag          'Eintragen in der Zieltabellenzelle
                 End If
                 '-------------
              End If
         End Select
       Next lngSpalte
    End With 'rwQuelle.Range
  Next rwQuelle
  lstZiel.Range.Columns.AutoFit
End Sub

Das Makro befindet sich im Codemodul des Arbeitsblattes "Kalender" und reagiert auf die Auswahl durch die aktive Zelle, falls diese in der Kopfzeile (Zelle "Datum") sich befindet.
Die Kommentarzeilen, die mit "<==..." beginnen, verweisen auf VBA-Code, der Daten aus der Quell- bzw. Zieltabelle enthält. Falls diese geändert werden, müsste der Code entsprechend angepasst werden.

Datei liegt bei.

 

Hallo AlterDresdner, Hallo Anton Exl,

ich danke euch vielmals für eure Unterstützung. Das hat mir sehr geholfen und ich habe es auf meinen Fall anwenden können.
Besten Dank!