title image


Smiley Vom Ersteller: kompletter Code
Hi,



oh, auch ein Banker? :-)



ich hab nochmal den kompletten Code der Funzen rausgesucht. Mglw. hab ich mich damals verpostet. Habe die Funz aber inzwischen weiterentwickelt; jetzt läßt sich die Summe optional auch auf einen bestimmten Tag begrenzen.



Aufruf der BPAggregat dann z.B. durch



? BPAggregat("1300","Bilanzposition","ZEBTag","Kapital","0","Betriebsstelle")



summiert alle BPs, die zur 1300 gehören (gesamter BP-Baum ab 1300 inkl. abwärts!) im Kapital für Betriebsstelle 0.







Function BPAggregat(strBPWert As String, strBPFeld As String, strTabelle As String, strSummenFeld As String, _

Optional strBSTWert As String, Optional strBSTFeld As String, _

Optional dteDatumWert As Variant, Optional strDatumFeld As Variant) As Double

'rekursive Funktion

'liefert die Kapital- oder Zinssumme aus der angegebenen Tabelle über rekursiven Drilldown entlang der BP-Hierarchie.

'Als Tabelle sollte die Abfrage "VBA 01503 - ZEB je BST auf allen Ebenen (K+Z getrennt)" genutzt werden.

'Dann kann durch Angabe der optionalen Betriebsstelle auch der Anteil der Betriebsstelle isoliert ermittelt werden.





Dim aryBPs() As String 'Array der Töchter der BP

Dim BP As Variant

Dim strKriterium As String

Dim rstDaten As DAO.Recordset



If strBSTWert "" And strBSTFeld "" Then

strKriterium = BuildCriteria(strBSTFeld, dbInteger, "=" & strBSTWert) _

& " AND " & BuildCriteria(strBPFeld, dbInteger, "=" & strBPWert) 'Suche nach BST udn BP

Else

strKriterium = BuildCriteria(strBPFeld, dbInteger, "=" & strBPWert) 'Suche nur nach BP

End If



If Not IsMissing(dteDatumWert) And Not IsMissing(strDatumFeld) Then

strKriterium = strKriterium & " AND [" & strDatumFeld & "] = #" & ConvDateInSql((dteDatumWert)) & "#"

End If



'BPAggregat = Nz(DSum("[" & strSummenFeld & "]", strTabelle, strKriterium))

Set rstDaten = CurrentDb.OpenRecordset("SELECT Sum(" & strSummenFeld & ") As Wert FROM " & strTabelle _

& " WHERE " & strKriterium)

BPAggregat = Nz(rstDaten!Wert)

rstDaten.Close

Set rstDaten = Nothing

aryBPs = Split(BPTöchter(strBPWert), ";")

For Each BP In aryBPs

BPAggregat = BPAggregat + BPAggregat((BP), strBPFeld, strTabelle, strSummenFeld, strBSTWert, strBSTFeld, dteDatumWert, strDatumFeld)

Next BP

End Function





Function BPEbene(strBP As String) As Double

'rekursive Funz,

'gibt die Ebene der übergebenen Bilanzposition in der BP-Hierachie zurück

Dim strMutter As String



strMutter = Nz(DLookup("[übergeordneter Schluessel]", "Zuordnung_Bilanzpositionen", "Schluessel = " & strBP), "")

If strMutter = "" Then

'keine Mutter vorhanden: BP-Ebene 1

BPEbene = 1

Else

'Mutter vorhanden: Ebene um 1 erhöhen und Ebene der Mutter feststellen (Rekursion)

BPEbene = 1 + BPEbene(strMutter)

End If

End Function





Function BPIstTiefsteEbene(strBP As String) As Boolean

'ermittelt, ob die übergebene BP die "tiefste" Ebene in ihren Vorgängern und Nachkommen ist.

'Rückgabe: True, wenn die BP irgendwo als Mutter vorkommt; false, wenn nicht

'NB: Es sind grds. auch Daten für BPs zu erwarten, die *nicht* tiefste Ebene sind, z.B.

'aus Änderungssätzen für BP 1300, weil u.U. keine feinere Detaillierung machbar ist.



If BPTöchter(strBP) = "" Then

BPIstTiefsteEbene = True

Else

BPIstTiefsteEbene = False

End If

End Function





Function BPMutter(strBP As String)

'ermitelt die übergeodnete BP zur übergebenen BP

BPMutter = DLookup("[übergeordneter Schluessel]", "Zuordnung_Bilanzpositionen", "[Schluessel] = " & strBP)

End Function





Function BPTöchter(strBP As String, Optional strDelim As String = ";", Optional blnTotal As Boolean = False) As String

'gibt die Tochter-BPs der übergebenen BP an, also die BPs, bei denen

'die übergebene BP als übergeordneter Schlüssel eingetragen ist.

'Bei mehreren Töchtern werden die Töchter durch den Delimiter getrennt

Dim rstBPs As DAO.Recordset

Dim strDummy As String



Set rstBPs = CurrentDb.OpenRecordset("SELECT * FROM Zuordnung_BIlanzpositionen ORDER BY Schluessel")

If Not rstBPs.EOF Then

rstBPs.MoveLast

End If

If rstBPs.RecordCount > 0 Then

rstBPs.MoveFirst

Do While True

rstBPs.FindNext "[übergeordneter Schluessel] = " & strBP

If rstBPs.NoMatch Then

'übergebene BP hat keine Töchter

Exit Do

Else

'übergebene BP hat Töchter

If blnTotal Then

'prüfen, ob die gefundene Tochter weitere Töchter hat

If BPTöchter(rstBPs!Schluessel, , False) "" Then

'gefundene Tochter hat eigene Töchter

strDummy = strDummy & strDelim & rstBPs!Schluessel & strDelim & BPTöchter(rstBPs!Schluessel, strDelim, False)

Else

'gefundene Tochter hat keine eigenen Töchter

strDummy = strDummy & strDelim & rstBPs!Schluessel

End If

Else

'Prüfung auf weitere Töchter kann entfallen. Tochter anfügen

strDummy = strDummy & strDelim & rstBPs!Schluessel

End If

'rstBPs.FindNext "[übergeordneter Schluessel] = " & strBP

End If

Loop

End If

rstBPs.Close

Set rstBPs = Nothing

'evtl. führendes Semikolon abschneiden

If Left$(strDummy, 1) = ";" Or Left$(strDummy, 1) = "," Then

strDummy = Right(strDummy, Len(strDummy) - 1)

End If

BPTöchter = strDummy

End Function





Function BPUrMutter(strBP As String) As Integer

'rekursive Funktion

'Gibt die BP auf erster Ebene zurück, der die übergebene BP zugeordnet ist

'(die Hierrchie wird ganz nach oben durchlaufen)



If IsNull(BPMutter(strBP)) Then

BPUrMutter = strBP 'BP auf erster Ebene

Else

BPUrMutter = BPUrMutter(BPMutter(strBP)) 'Mutter der übergebenen BP prüfen

End If

End Function


Martin
Atrus2711 ät gmx punkt net
Meine Beiträge zu MS Office betreffen stets Version 2000,
wenn nicht anders angegeben.




geschrieben von


Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: