AW: Tabelle Aufgrund von/bis Datum (Periodebereich)
04.10.2007 15:21:00
fcs
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 = 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