Minium, Maximum und Mittelwert mit VBA

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub manuel_keineIdee() ' manuel_keineIdee Macro Dim zell As Range Dim Datenblatt As Worksheet Dim Teile As String Dim Werte As String Set Datenblatt = ActiveSheet Set zell = Range("A1").CurrentRegion ' Adressen basteln Teile = "'" & Datenblatt.Name & "'!" & Range(zell.Columns(1).Rows(2), zell.Columns(1).Rows( _ zell.Rows.Count)).Address(ReferenceStyle:=xlR1C1) Werte = "'" & Datenblatt.Name & "'!" & Range(zell.Columns(2).Rows(2), zell.Columns(2).Rows( _ zell.Rows.Count)).Address(ReferenceStyle:=xlR1C1) Worksheets.Add 'Daten "unique" kopieren zell.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1" _ ), Unique:=True Range("B1").FormulaR1C1 = "Mittelw" Range("C1").FormulaR1C1 = "min" Range("D1").FormulaR1C1 = "max" Range("B2").FormulaR1C1 = _ "=SUMIF(" & Teile & ",RC[-1]," & Werte & ")/ " & _ "COUNTIF(" & Teile & ",RC[-1])" Range("C2").FormulaArray = "=MIN(IF(" & Teile & _ "=RC[-2]," & Werte & ",MAX(" & Werte & ")))" Range("D2").FormulaArray = "=MAX((" & Teile & "=RC[-3])*" & Werte & ")" End Sub

Sub test() With Sheets("Informationen") Sheets("Upload").Range("C:C,O:O").Copy .Cells(1, 1).PasteSpecial xlPasteValues .Range("A:B").Sort Key1:=.Cells(1, 1), order1:=xlAscending, _ key2:=.Cells(1, 2), order2:=xlAscending, _ Header:=xlYes With .UsedRange.Columns(2) With .Resize(.Rows.Count - 1, 4).Offset(1, 1) .Columns(1).FormulaR1C1 = "=IF(RC1R[1]C1,RC2,R[1]C)" 'Max .Columns(3).FormulaR1C1 = "=IF(RC1R[1]C1,RC2,Sum(RC2,R[1]C))" 'Summe .Columns(4).FormulaR1C1 = "=IF(RC1R[1]C1,1,R[1]C+1)" 'Anzahl .Columns(2).FormulaR1C1 = "=IF(RC1R[-1]C1,RC[1]/RC[2],"""")" 'Mittelwert .Formula = .Value End With End With .Range("A:F").RemoveDuplicates 1, xlYes .Range("E:F").EntireColumn.Delete .Range("B1:D1").Value = Array("Min", "Max", "Mittelwert") End With End Sub

Sub test() With Sheets("Informationen") Sheets("Upload").Range("C:C,E:E, O:O").Copy .Cells(1, 1).PasteSpecial xlPasteValues .Range("A:B").Sort Key1:=.Cells(1, 1), Order1:=xlAscending, _ key2:=.Cells(1, 2), order2:=xlAscending, _ key3:=.Cells(1, 3), order3:=xlAscending, _ Header:=xlYes With .UsedRange.Columns(3) With .Resize(.Rows.Count - 1, 4).Offset(1, 1) .Columns(1).FormulaR1C1 = "=IF(RC1R[1]C1,RC2,R[1]C)" 'Max .Columns(3).FormulaR1C1 = "=IF(RC1R[1]C1,RC2,Sum(RC2,R[1]C))" 'Summe .Columns(4).FormulaR1C1 = "=IF(RC1R[1]C1,1,R[1]C+1)" 'Anzahl .Columns(2).FormulaR1C1 = "=IF(RC1R[-1]C1,RC[1]/RC[2],"""")" 'Mittelwert .Formula = .Value End With End With .Range("A:F").RemoveDuplicates 1 And 2, xlYes .Range("E:G").EntireColumn.Delete .Range("B1:D1").Value = Array("Min", "Max", "Mittelwert") End With End Sub

Hi
schau mal_
die Formel für das maximum lautet bisher (Produkt in Spalte A, Zahl in Spalte B, Formel in C2)

=Wenn($A2$A3;B2;Max($B2;C3))

wenn jetzt das Datum in Spalte B hinzukommt und die Zahl nach C wandert, muss die Formel lauten, wenn du nach Jahr und Produkt zusammenfassen willst (Formel in D2):

=Wenn(Oder($A2$A3;$B2$B3);$C2;Max($C2;D3))

so kannst du dann auch die anderen Formeln anpassen.
mach das erstmal von Hand (nachdem du auch das kopieren und sortieren von Hand gemacht hast)
wenn die Formeln dann den passenden Wert liefern, kannst du dir die Formelschreibweise für den VBA-Code anschauen, in dem du die Zelle mit der Formel selektierst und dann im Direktfenster den Befehl ?Selection.FormulaR1C1 eingibst, oder du das eingeben der Formel mit dem Recorder aufzeichnest. (wenn du die Formeln in Excel in die Tabellen schreibst, solltest so alle Zellbezüge absolut setzen, für die das möglich ist. die Formeln werden dann in der VBA-Schreibweise R1C1 übersichtlicher.
auch das mit dem RemoveDuplicates solltest du dir nochmal mit dem Recorder aufzeichen und genauer anschauen, wie das beschrieben wird wenn mehrere Spatlen für die Duplikatprüfung verwendet werden.
Gruss Daniel

Public Sub Nach_Artikel_addieren_I() Dim Dic_Zaehlen As Object Dim Dic_Summe As Object Dim vTemp As Variant Dim iTemp As Integer Dim lZeile As Long Dim dMin As Double Dim dMax As Double Dim lLetzte As Long Application.ScreenUpdating = False Set Dic_Zaehlen = CreateObject("Scripting.Dictionary") Set Dic_Summe = CreateObject("Scripting.Dictionary") With ThisWorkbook.Worksheets("Upload") vTemp = .Range("C2:O" & .Cells(.Rows.Count, 3).End(xlUp).Row) End With For iTemp = 1 To UBound(vTemp) Dic_Zaehlen(vTemp(iTemp, 1)) = Dic_Zaehlen(vTemp(iTemp, 1)) + 1 ' das Item um _ 1 hochzählen Dic_Summe(vTemp(iTemp, 1)) = Dic_Summe(vTemp(iTemp, 1)) + vTemp(iTemp, 13) ' den Wert in _ O zu dem Item dazuaddieren. Next iTemp ' Ausgabe in die Spalten A:M With ThisWorkbook.Worksheets("Informationen") lLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row If lLetzte dMax Then dMax = vTemp(iTemp, 13) End If Next iTemp .Range("D" & lZeile).Value = dMin .Range("E" & lZeile).Value = dMax If .Range("C" & lZeile).Value 0 Then _ .Range("F" & lZeile).Value = .Range("D" & lZeile).Value / .Range("C" & lZeile). _ Value Next lZeile End With Application.ScreenUpdating = True End Sub

Hallo Manuel,
erwartest du die Summe so, wie es dieses Makro - übrigens jetzt mit Dokumentation - ausgibt?
Gruß Peter

Public Sub Nach_Artikel_addieren() ' dieses Makro berücksichtigt die Jahreszahl aus dem Datum  _
in Spalte E
Dim Dic_Zaehlen  As Object  ' das Dictionary Objekt zum Zählen der Vorkommen
Dim Dic_Summe    As Object  ' das Dictionary Objekt zur Addition der Werte
Dim vTemp        As Variant ' ein tempoträrer Array zur schnelleren Bearbeitung
Dim iTemp        As Integer ' der For/Next Schleifen Index zum temporären Array
Dim sText        As String  ' der zusammengesetzte Key zur Speicherung im Dictionary
Dim lLetzte      As Long    ' dei letzte belegte Zeile im Ergebnis-Blatt
Dim vSplit       As Variant ' ein Bereich zum erneuten Aufteilen der Key-Werte
Dim lZeile       As Long    ' For/Next Schleifen-Index -hier die Zeile
Dim dMin         As Double  ' der Minimal-Wert
Dim dMax         As Double  ' der Maximal-Wert
Application.ScreenUpdating = False ' kein Bildschirm-Update während des Makro-Laufs
Set Dic_Zaehlen = CreateObject("Scripting.Dictionary") ' das Dictionary zuordnen
Set Dic_Summe = CreateObject("Scripting.Dictionary")   ' das Dictionary zuordnen
'     zur schnelleren Bearbeitung (besseren Performance) die Eingaben in ein Array speichern
With ThisWorkbook.Worksheets("Upload")
vTemp = .Range("C2:O" & .Cells(.Rows.Count, 3).End(xlUp).Row)
End With
'     die Eingabe-Werte an die Dictionary übergeben
For iTemp = 1 To UBound(vTemp)
'        den Key aus Artikelnummer und Jahr zusammensetzen
sText = Trim$(vTemp(iTemp, 1)) & "##" & Year(vTemp(iTemp, 3))
Dic_Zaehlen(sText) = Dic_Zaehlen(sText) + 1             ' das Item um 1 hochzählen
Dic_Summe(sText) = Dic_Summe(sText) + vTemp(iTemp, 13)  ' den Wert in O zu dem Item  _
dazuaddieren.
Next iTemp
'     Ausgabe in die Spalten A:G
With ThisWorkbook.Worksheets("Informationen")
lLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row ' die letzte belgte Zeile in Spalte 1 = A  _
feststellen
If lLetzte  dMax Then dMax = vTemp(iTemp, 13)
End If
Next iTemp
.Range("E" & lZeile).Value = dMin ' den Min-Wert ausgeben
.Range("F" & lZeile).Value = dMax ' den Max-Wert ausgeben
'           den Durchschnitts-Wert errechnen
If .Range("C" & lZeile).Value  0 Then _
.Range("G" & lZeile).Value = .Range("D" & lZeile).Value / .Range("C" & lZeile). _
Value
'           Artiukel und Jahreszahl in getrennte Spalten ausgeben
.Range("A" & lZeile).Value = vSplit(0)
.Range("B" & lZeile).Value = vSplit(1)
Next lZeile
'         die Zeile für die Gesamt-Summe aufbauen
.Range("C" & lLetzte + 2).Value = "Gesamt"
.Range("D" & lLetzte + 2).Value = WorksheetFunction.Sum(.Range("D4:D" & lLetzte))
End With
Application.ScreenUpdating = True ' das Bildschirm-Update wieder zulassen
Set Dic_Zaehlen = Nothing ' die Ressourcen wieder freigeben
Set Dic_Summe = Nothing
End Sub

Beliebteste Forumthreads (12 Monate)

Minium, Maximum und Mittelwert mit VBA

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Minium, Maximum und Mittelwert mit VBA

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread