Marko über sumif Funktion

addi23 · 1970-01-01T00:00:00+00:00

Hallo, ich habe mal eine Frage an Euch: Ich muss täglich mehrere Excel-Sheets erstellen (immer unterschiedlich umfangreich). Wenn ich meine manuelle Aufbereitung fertiggestellt habe muss ich eine sumif-Funktion über einen Bereich laufen lassen. Hier gehe ich auf manuellem Weg wie folgt vor: In der Liste gibt es mehrere identische Kriterien auf die ich eine Summe ziehen möchte (es gibt also mehrere Zeilen in denen z.B. der Kunde A hinterlegt ist). In einer kleinen Liste innerhalb des Sheets möchte ich nun die sumif-Information pro Kunde haben. Ich habe nun die Spalte mit den ganzen Kundennummern rauskopiert - in ein extra Sheet kopiert - und ein Makro drüberlaufen lassen in dem alle doppenlten Einträge gelöscht werden sollen. Das Ergebnis habe ich denn wieder in mein Sheet kopiert und dann daneben die sumif Funktion hinterlegt, die Bereiche markiert und die Zahlen ermittelt. Meine Frage ist ob man dies auch in einem Makro zusammenfassen kann? Ich stelle mir vor, das ich den sumif-Breich markiere - in der ersten Spalte dieses markierten Bereiches sind nun ja die Kunden hinterlegt, wo zunächst mal doppelte Werte ignoriert werden müssen, anschließend sollte denn über den kompletetten Bereich die sumif Funktion laufen, wobei die letzte Spalte der eingangs markierten Bereichs die sum_range Werte beinhaltet. Das Ergebnis soll dann 5 oder 6 Zeilen unterhalb des markierten Bereiches wiedergegeben werden. Ist das möglich? Vielen Dank schon mal vorab für Euer Bemühen. VG addi-23

Hallo Addi,
na also, mich hatten nur die 50000 irritiert, weil ich glaubte, die kommen aus einer Berechnung.
Beim Folgenden Code wirst du aufgefordert, den bereich mit den Vorgaben auszuwählen, in deiner Beispieldatei wäre das der Bereich A14:B16, oder auch A15:B16, die Überschriften kannst du einschliessen oder nicht, das ist egal. In die ersten freien Spalten rechts der Liste, werden die Werte eingetragen.

Sub berechnung()
  Dim lngLast As Long, lngCol As Long
  Dim rng As Range, strKrit As String, strVal As String

  On Error Resume Next
  Set rng = Application.InputBox("Bitte wählen sie den Bereich mit den Vorgaben aus" & vbLf & _
    vbLf & "Der Bereich muss 2 Spalten umfassen!", "Berechnung", Selection.Address, Type:=8)
  On Error GoTo 0

  If Not rng Is Nothing Then
    If rng.Columns.Count <> 2 Then
      MsgBox "Der Bereich '" & rng.Address(0, 0) & "' ist ungültig!" & vbLf & vbLf & _
        "Ein gültiger Bereich muss zwei Spalten umfassen!", vbInformation, "Fehler"
      Exit Sub
    Else
      strKrit = rng.Columns(1).Address
      strVal = rng.Columns(2).Address
      lngCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
      lngLast = Cells(Rows.Count, 3).End(xlUp).Row

      Cells(1, lngCol) = "Anteil"
      Cells(1, lngCol + 1) = "Verteilung"
      Range(Cells(1, lngCol), Cells(1, lngCol + 1)).Font.Bold = True
      Cells(2, lngCol).Formula = "=G2/SUMIF($C$2:$C$" & lngLast & ",C2,$G$2:$G$" & lngLast & ")"
      Cells(2, lngCol + 1).Formula = "=J2*INDEX(" & strVal & ",MATCH(C2," & strKrit & ",0))"
      Range(Cells(2, lngCol), Cells(lngLast, lngCol + 1)).FillDown
      Range(Cells(2, lngCol), Cells(lngLast, lngCol + 1)) = Range(Cells(2, lngCol), Cells(lngLast, lngCol + 1)).Value
      Columns(lngCol).NumberFormat = "0.00%"
      Columns(lngCol + 1).NumberFormat = "#,##0.00 $"
    End If
  End If

  Set rng = Nothing
End Sub

Gruß Sepp

Hallo Addi,
kein Problem;-))

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub berechnung()
  Dim lngLast As Long, lngCol As Long, lngIndex As Long
  Dim rng As Range, strKrit As String, strVal As String
  Dim vntList As Variant, vntRet() As Variant

  On Error Resume Next
  Set rng = Application.InputBox("Bitte wählen sie den Bereich mit den Vorgaben aus" & vbLf & _
    vbLf & "Der Bereich muss 2 Spalten umfassen!", "Berechnung", Selection.Address, Type:=8)
  On Error GoTo 0

  If Not rng Is Nothing Then
    If rng.Columns.Count <> 2 Then
      MsgBox "Der Bereich '" & rng.Address(0, 0) & "' ist ungültig!" & vbLf & vbLf & _
        "Ein gültiger Bereich muss zwei Spalten umfassen!", vbInformation, "Fehler"
      Exit Sub
    Else
      strKrit = rng.Columns(1).Address
      strVal = rng.Columns(2).Address
      lngCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
      lngLast = Cells(Rows.Count, 3).End(xlUp).Row

      Cells(1, lngCol) = "Anteil"
      Cells(1, lngCol + 1) = "Verteilung"
      Range(Cells(1, lngCol), Cells(1, lngCol + 1)).Font.Bold = True

      Cells(2, lngCol).Formula = _
        "=G2/SUMIF($C$2:$C$" & lngLast & ",C2,$G$2:$G$" & lngLast & ")"

      Cells(2, lngCol + 1).Formula = _
        "=" & Cells(2, lngCol).Address(0, 0) & "*INDEX(" & strVal & _
        ",MATCH(C2," & strKrit & ",0))"

      With Range(Cells(2, lngCol), Cells(lngLast, lngCol + 1))
        .FillDown
        .Value = .Value
        .Columns(1).NumberFormat = "0.00%"
        .Columns(2).NumberFormat = "#,##0.00 $"
      End With

      'Summen
      vntList = UniqueList(Range(Cells(2, 4), Cells(lngLast, 4)))
      Redim Preserve vntRet(1 To UBound(vntList) + 2, 1 To 2)
      vntRet(1, 1) = "Kennummer"
      vntRet(1, 2) = "Summe"
      For lngIndex = 0 To UBound(vntList)
        vntRet(lngIndex + 2, 1) = "'" & vntList(lngIndex)
        vntRet(lngIndex + 2, 2) = Application.SumIf(Range(Cells(2, 4), _
          Cells(lngLast, 4)), vntList(lngIndex), Range(Cells(2, lngCol + 1), _
          Cells(lngLast, lngCol + 1)))
      Next

      With Cells(rng(1, 1).Row + rng.Rows.Count - 1, 1).Offset(3, 0)
        .Resize(UBound(vntRet, 1), 2) = vntRet
        .Resize(UBound(vntRet, 1), 2).Columns(1).NumberFormat = "00000"
        .Resize(UBound(vntRet, 1), 2).Columns(2).NumberFormat = "#,##0.00 $"
      End With
    End If
  End If

  Set rng = Nothing
End Sub

Private Function UniqueList(Matrix As Range, Optional IncludeNull As Boolean = True, Optional Sorted As Boolean = True) As Variant
  Dim objDic As Object, rng As Range, varTmp() As Variant, vntExclude As Variant

  vntExclude = IIf(IncludeNull, "", 0)

  Set objDic = CreateObject("Scripting.Dictionary")

  For Each rng In Matrix
    If rng.Value <> vntExclude Then objDic(rng.Value) = 0
  Next

  varTmp = objDic.keys

  If Sorted Then QuickSort varTmp

  UniqueList = varTmp

  Set objDic = Nothing
End Function

Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
  Dim P1&, P2&, T1 As Variant, T2 As Variant

  UG = IIf(IsMissing(UG), LBound(data), UG)
  OG = IIf(IsMissing(OG), UBound(data), OG)

  P1 = UG
  P2 = OG
  T1 = data((P1 + P2) / 2)

  Do

    Do While (data(P1) < T1)
      P1 = P1 + 1
    Loop

    Do While (data(P2) > T1)
      P2 = P2 - 1
    Loop

    If P1 <= P2 Then
      T2 = data(P1)
      data(P1) = data(P2)
      data(P2) = T2
      P1 = P1 + 1
      P2 = P2 - 1
    End If

  Loop Until (P1 > P2)

  If UG < P2 Then QuickSort data, UG, P2
  If P1 < OG Then QuickSort data, P1, OG

End Sub

Gruß Sepp

Forumthread: Marko über sumif Funktion

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Marko über sumif Funktion

Forumthread: Marko über sumif Funktion

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread