Microsoft Excel

Herbers Excel/VBA-Archiv

Tabelle Aufgrund von/bis Datum (Periodebereich)

Betrifft: Tabelle Aufgrund von/bis Datum (Periodebereich) von: Robert
Geschrieben am: 03.10.2007 23:46:46

Guten Abend Leute,

Hoffentlich könnt ihr mich mit folgender Sache helfen.

Ich möchte mit VBA erreichen dass wenn ich in Zelle A1 ein Datum (Periode Start), Zelle A2 (Periode Ende) und in A3 einen ID eingebe, eine neue Tabelle Aufgrund Daten in Tabelle1 erstellt wird.

Eingabe z.B. Periode Start: 01.01.2007
Periode Ende: 31.12.2007
ID: BBB

Die Zeilen mit ID „BBB“ wo sich der START und/oder ENDDATUM in Tabelle1
mit dem Periodebereich überschneiden sollten in einer neuen Tabelle eingefügt werden.

Tabelle1

Siehe Word.doc
https://www.herber.de/bbs/user/46516.doc

Ich hätte gerne dass die Tabelle2 dann in etwa so aussieht:

Siehe Word.doc
https://www.herber.de/bbs/user/46516.doc

In Spalte A sollte der Periode Bereich abgebildet werden. In Zeile 20
hätte ich gerne alle Typen die eine Überschneidung mit dem Periodenbereich haben.

Sieht ihr da eine Möglichkeit? Freue mich auf Hilfe da ich sonst nicht mehr weiter komme.

Gruss, Robert

  

Betrifft: AW: Tabelle Aufgrund von/bis Datum (Periodebereich) von: fcs
Geschrieben am: 04.10.2007 15:21:35

Hallo Robert,

Möglichkeiten gibt es fast immer und eine "halbwegs saubere" Tabelle Datenmäßig zu zerpflücken/aufzubröseln ist eigentlich immer eine Fleißaufgabe. Nachfolgend ein paar Prozeduren , die die Daten in etwa in der gewünschten Form darstellen.

Ich weiss ja nicht für welche Zwecke du die Daten in der gewünschten Form Darstellen willst. Reicht da die Auswertung der Daten per Pivot-Tabellenbericht nicht. Hier fehlen dann halt die regelmäßigen Monats-Abstände in den Zeilen, ansonsten hat manda auch schnell einen Datenüberblick.

Gruß
Franz

Option Explicit

Sub Schaltfläche2_BeiKlick()
  'Wertetabelle aufbauen
  Dim tStart As Date, tEnde As Date, lZeileDatum As Long
  Dim wks As Worksheet
  Dim iSpalte As Integer, lZeile As Long, Monat As Integer, iI%
  Dim wksDaten As Worksheet
  Dim boVorhanden As Boolean
  Dim strID As String, strTyp As String, strTypNeu As String
  
  Const lZ_Start As Long = 20 'Zeile mit Typ-Einträgen
  Const iSpStart As Integer = 1 'Spalte mit Datums-Einträgen
  
  Set wksDaten = Worksheets("Tabelle1")
  Set wks = Worksheets("Tabelle2")
  'Vorgabewerte einlesen
  tStart = wks.Range("A1")
  tEnde = wks.Range("A2")
  strID = wks.Range("A3")
  
  With wks
  'Alteinträge Löschen
    lZeile = .Cells(.Rows.Count, iSpStart).End(xlUp).Row
    If lZeile > lZ_Start Then
      .Range(.Rows(lZ_Start + iSpStart), .Rows(lZeile)).Clear
    End If
    iSpalte = .Cells(lZ_Start, .Columns.Count).End(xlToLeft).Column
    If iSpalte > iSpStart Then
      .Range(.Cells(lZ_Start, iSpStart + 1), .Cells(lZ_Start, iSpalte)).Clear
    End If
    'Datumseinträge (jeweils der Monatsletzte)
    lZeile = lZ_Start
    For Monat = 1 To (Year(tEnde) - Year(tStart)) * 12 + Month(tEnde) - Month(tStart) + 1
      lZeile = lZeile + 1
      .Cells(lZeile, iSpStart).NumberFormat = "DD.MM.YYYY"
      .Cells(lZeile, iSpStart).Value = DateSerial(Year(tStart), _
          Month(tStart) + Monat, 1) - 1
    Next
    'Typeinträge
    iSpalte = iSpStart + 1
    For lZeile = 2 To wksDaten.Cells(.Rows.Count, 1).End(xlUp).Row
      If wksDaten.Cells(lZeile, 1).Value = strID Then
      If DatumsCheck(Start:=wksDaten.Cells(lZeile, 2), _
                    Ende:=IIf(IsEmpty(wksDaten.Cells(lZeile, 3)), tEnde, _
                          wksDaten.Cells(lZeile, 3)), _
                    PeriodeStart:=tStart, PeriodeEnde:=tEnde) = True Then
        
        strTypNeu = wksDaten.Cells(lZeile, 4).Value
        If IsEmpty(.Cells(lZ_Start, iSpalte)) Then
          .Cells(lZ_Start, iSpalte).NumberFormat = "@"
          .Cells(lZ_Start, iSpalte) = strTypNeu
        Else
          boVorhanden = False
          For iI = iSpStart + 1 To iSpalte
            If strTypNeu = .Cells(lZ_Start, iI) Then
              boVorhanden = True
              Exit For
            End If
          Next
          If boVorhanden = False Then
            iSpalte = iSpalte + 1
            .Cells(lZ_Start, iSpalte).NumberFormat = "@"
            .Cells(lZ_Start, iSpalte) = strTypNeu
          End If
        End If
      End If
      End If
    Next
    'Typeinträge sortieren
    .Range(.Cells(lZ_Start, iSpStart + 1), .Cells(lZ_Start, iSpalte)).Sort _
          Key1:=.Cells(lZ_Start, iSpStart + 1), Order1:=xlAscending, _
          Orientation:=xlLeftToRight, DataOption1:=xlSortNormal
    'Format für Werte aus Datentabelle übernehmen
    .Range(.Cells(lZ_Start + 1, iSpStart + 1), .Cells(.Rows.Count, _
        iSpStart).End(xlUp).Offset(0, iSpalte - iSpStart)).NumberFormat _
        = wksDaten.Cells(2, 5).NumberFormat
    'Werte einsortieren entsprechend Datumsbereich und Typ
    For lZeile = 2 To wksDaten.Cells(.Rows.Count, 1).End(xlUp).Row
      If wksDaten.Cells(lZeile, 1).Value = strID Then
      For lZeileDatum = lZ_Start + 1 To .Cells(.Rows.Count, iSpStart).End(xlUp).Row
        If DatumsCheck2(Start:=wksDaten.Cells(lZeile, 2), _
                    Ende:=IIf(IsEmpty(wksDaten.Cells(lZeile, 3)), tEnde, _
                    wksDaten.Cells(lZeile, 3)), _
                    Stichtag:=.Cells(lZeileDatum, iSpStart).Value) = True Then
          strTypNeu = wksDaten.Cells(lZeile, 4).Value
          For iI = iSpStart + 1 To iSpalte
            If strTypNeu = .Cells(lZ_Start, iI) Then
              .Cells(lZeileDatum, iI) = wksDaten.Cells(lZeile, 5).Value
            End If
          Next
        End If
      Next
      End If
    Next
  End With
End Sub

Function DatumsCheck(Start As Date, Ende As Date, PeriodeStart As Date, _
    PeriodeEnde As Date) As Boolean
  'Überprüfen, ob Start und/oder Ende in die Periode fallen (inklusive Grenzen)
  If Start <= PeriodeEnde And Ende >= PeriodeStart Then
    DatumsCheck = True
  End If
End Function
Function DatumsCheck2(Start As Date, Ende As Date, Stichtag As Date) As Boolean
  'Überprüfen, ob Stichtag innerhalb von Start und Ende fällt (inklusive Grenzen)
  If Stichtag >= Start And Stichtag <= Ende Then
    DatumsCheck2 = True
  End If
End Function




  

Betrifft: AW: Tabelle Aufgrund von/bis Datum (Periodebereich) von: Robert
Geschrieben am: 04.10.2007 19:26:18

Hallo Franz,

Vielen Dank! Dein Code beantwortet meine Frage. Die Zwecke? Also, ich bekomme jede Monat neue Daten(Indices und Werte). Anhand deines Codes kann ich die Gewichtung von Indices im Portfolio berechnen. In mein Beispiel stehen die % Zahlen für monatliche Gewichtung. So bald die Gewichtungstabelle steht, laufen weitere vba Codes die die monatliche oder halt periodische Portfolio Performance vom portfolio Gegenüber Benchmark berechnen. Dein Code muss ich für meine Zwecke anpassen aber dass werde ich ohne Probleme hinbekommen. Einfach Top, Franz!

Gruss, Robert




 

Beiträge aus den Excel-Beispielen zum Thema "Tabelle Aufgrund von/bis Datum (Periodebereich)"