Office: dbsumme als makro

Hallo zusammen

Ich habe folgendes problem: ich habe mit hilfe der dbsumme funktion eine neue liste erstellt die mir eine goße liste list auf die interressienden werte reduziert; in tabelle 1 befindet sich die ertellte liste in tabelle 2 befindet sich die liste aus der ausgewählt werden soll;

nun möchte ich diese liste mit einem makro programmieren und komme keinen schritt weiter: wie kann ich in der grundliste die entsprechenden wert finden und dann in die neue liste kopieren???

listen sind folgendermaßen aufgebaut: von a5 bis a100 befinden sich die kostenarten, in den spalten b1 bis bv1 die kostenstellen;

vielleicht hat jemand eine lösung, viel dank im voraus
lg

 

Hallo,

installiert man nachfolgendes VBA-Makro in einem allgem. Codemodul kann man statt der Tabellenblattfunktion DBSUMME(Datenbank,Feld,Kriterium) die benutzerdefinierte Funktion DB_Summe(Datenbank,Feld,Kriterium) verwenden.

Code:

Public Function DB_Summe(Datenbank As Range, Feld As Variant, Kriterium As Variant) As Double
  DB_Summe = WorksheetFunction.DSum(Datenbank, Feld, Kriterium)
End Function

Hier folgt ein Anwendungsbeispiel der neuen benutzerdef. Funktion DB_Summe(Datenbank,Feld,Kriterium):

	A	B	C	D	E
1	Feld1	Feld2	Feld3		Feld3
2	11	22	33		<400
3	111	222	333
4	1111	2222	3333		244

Zelle	Formel
E4	=DB_Summe(A1:C4;B1;E1:E2)

Mir ist allerdings nicht wirklich klar, wie man damit auf einfache Weise Listen erzeugen kann - die Funktion ist dann gut, wenn man einzelne Summen auf der Basis (ganz) spezieller Filterungen erstellen will.

 

hallo

danke für die hilfe.. man könnte natürlich auch dbmax oder dergleichen verwenden aber ich habe zeilen drinnen bei denen eine summe über mehrere konten berechnet wird...

habe gestern noch selbst eine lösung entwickelt:

Sub listefuellen()
Dim startkonto As Integer, j As Integer, startkst As Integer, y As Integer
Dim j2 As Integer, i2 As Integer

Dim wert As Variant, konto1 As Variant, konto2 As Variant, kostenstelle As Variant

Worksheets("Tabelle1").Activate


spalte:
Application.ScreenUpdating = False

For j = 2 To 100 Step 1
kostenstelle = Cells(5, j)
If kostenstelle = "" Then GoTo ende

startkonto = 8 'startzeile
Do While Cells(startkonto, 1) <> "" 'bei zelle acht starten
'Worksheets("Tabelle1").Activate
startkonto = startkonto + 1 ' eine zeile nach unten
konto1 = Cells(startkonto, 1) 'konto in die variable einlesen


Worksheets("Tabelle2").Activate
For j2 = 1 To 100 Step 1

If Cells(1, j2) = kostenstelle Then 'richtige kostenstelle suchen
For i2 = 1 To 400 Step 1 'wenn gefunden, entsprechende kontozeile suchen

If Cells(i2, 2) = konto1 Then
wert = Cells(i2, j2) 'zelle mit beiden zählern in wert kopieren
GoTo kopieren 'aus forschleife aussteigen und zu kopieren gehen
End If

Next i2

End If
Next j2

kopieren:

Worksheets("Tabelle1").Activate 'zu liste wechseln
Cells(startkonto, j) = wert 'zelle in die erichtige zelle springen und wert einfügen

Loop


Next j

Application.ScreenUpdating = True

ende:


lg

 

Hallo,
folgendes Makro müsste auch genügen. Du müsstest eventuell überprüfen, ob die abgefragten Bereiche genügend groß für Deinen Datenbestand sind.

Code:

Public Sub ListeFüllen2()
  Dim Zl As Integer, Sp As Integer
  Dim Kostenstelle As String, Konto As String
  
  Application.ScreenUpdating = False
  Worksheets("Tabelle1").Activate
  For Sp = 2 To 100
    Kostenstelle = Cells(5, Sp).Value
    If Kostenstelle = "" Then Exit For
    For Zl = 8 To 500
      Konto = Cells(Zl, 1).Value
      If Konto = "" Then Exit For
        
      Cells(Zl, Sp).Value = GetWertTabelle2(Konto, Kostenstelle)
      
    Next Zl
  Next Sp
  Application.ScreenUpdating = True  

End Sub
Private Function GetWertTabelle2(Konto1 As String, Kostenstelle1 As String) As Variant
  Dim Kostenstelle2 As String, Konto2 As String, Wert2 As Variant
  Dim Zl As Integer, Sp As Integer
  
  GetWertTabelle2 = Empty
  
  With Worksheets("Tabelle2")
      For Sp = 3 To 250
        Kostenstelle2 = .Cells(1, Sp).Value
        If Kostenstelle2 = "" Then Exit For
        If Kostenstelle2 <> Kostenstelle1 Then Exit For
        For Zl = 2 To 1000
          Konto2 = .Cells(Zl, 2).Value
          If Konto2 = "" Then Exit For
          If Konto2 <> Konto1 Then Exit For
          GetWertTabelle2 = .Cells(Zl, Sp).Value
          Exit Function
        Next Zl
      Next Sp
  End With
  
End Function

 

vielen dank für die hilfen! hab alles geschafft was ich wollte!

lg