Marko über sumif Funktion

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

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

Sub DblFind() Dim iRow As Integer, iRowL As Integer iRowL = Cells(Cells.Rows.Count, 1).End(xlUp).Row For iRow = iRowL To 1 Step -1 If WorksheetFunction.CountIf(Columns(1), Cells(iRow, 1)) > 1 Then Rows(iRow).Delete End If Next iRow End Sub

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

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Marko über sumif Funktion

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

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread