Kann mir jemand helfen biette, ein Makro von von Klaus-Dieter Oppermann richtig anzupassen;
Das Orgnalle Makro;
Sub liste_auswerten()
' findet in einer Liste, die nicht sortiert sein muss
' alle vorkommenden Artikel. Diese werden mit dem Einzelpreis
' und der Gesamtanzahl in einer neuen Liste ausgegeben.
' Der Gesamtpreis wird errechnet.
' Geschrieben von Klaus-Dieter Oppermann, Oktober 2005
' Variablen deklarieren
Dim iZiel As Integer ' Letzte gefüllte Zelle
Dim az As Integer ' Zähler für Arrayfelder
Dim i As Integer ' Schleifenzähler (Arrays füllen)
Dim t As Integer ' Schleifenzähler (Gesamtpreise und Gesamtanzahl _
ermitteln)
Dim arr() As Variant ' Array für Artikelausgabe
Dim arr2() As Variant ' Array für Einzelpreisausgabe
iZiel = Range("A65536").End(xlUp).Row ' Letzte gefüllte Zelle ermitteln (in Spalte A)
' Arrays dimensionieren
ReDim arr(iZiel, 0) ' Artikel
ReDim arr2(iZiel, 0) ' Einzelpreise
' Arrays mit Werten füllen
For i = 2 To UBound(arr) ' laufe von Zeile 2 bis _
_
Tabellenende
If Application.WorksheetFunction.CountIf(Range(Cells(i, 1), _
Cells(1, 1)), Cells(i, 1).Value) = 1 Then ' wenn Artikel das _
erste Mal vorkommt, dann ...
arr(az, 0) = Cells(i, 1).Value ' ... Name in Array _
einlesen
arr2(az, 0) = Cells(i, 2).Value2 ' ... Einzelpreis in _
Array einlesen
az = az + 1 ' ... Zähler für _
Arrayfeld plus 1
End If ' Ende der Auswertung
Next i ' Schleifenzähler plus _
_
1
' Inhalte ausgeben
Range("E2", "E" & UBound(arr)) = arr ' Artikelnamen in _
Ausgabebereich schreiben
With Range("F2", "G" & UBound(arr)) ' Ausgabbereich für _
Beträge
.NumberFormat = "#,##0.00 $" ' Währungsformat _
festlegen
.Value = arr2 ' Beträge eintragen
End With ' Ende des Eintrags
For t = 2 To az + 1 ' laufe von Zeile 2 bis _
_
Listenende
Cells(t, 8) = Application.WorksheetFunction.SumIf(Range _
(Cells(232, 1), Cells(2, 1)), Cells(t, 5), Range("C2:C232")) ' Gesamtmenge berechnen
Cells(t, 7) = Cells(t, 8) * Cells(t, 6) ' Gesamtpreis berechnen
Next t ' Schleifenzähler plus _
_
1
Columns("E:H").EntireColumn.AutoFit ' Spalten auf optimale _
_
Breite
End Sub
Gesuchte Lösung;
In Spalten A (ab A2) bis A16000 sind numerische Artikel Nummer
In Spalte F sind dessen gesammt Wert Summe
In Spalte A wiederholen sich sehr oft und sehr viel gleiche Artikel Nummer.
Mit Makro "liste_auswerten" von Klaus wollte ich die Spalte A auslesen und alle Artikel Nummer einmal auslesen.
Ab N2 sollen nach unten alle gefundene Artikel Nummer eingetragen werde.
Ab O2 sollen nach unten alle Werte(Vorsicht, es gibt positive und negative Werten) von diesen Artikel Nummer zusammen addiert werden.
In letzte O Zeile soll Gesamt Wert von O2: bis zum letzten Betrag zusammen gerechnet werden.
Als Beispiel:
Spalte A(ArtNum) ...... Spalte F(Werte)
11111.........................................3
88888.........................................1
11111.........................................7
44444........................................-2
88888.........................................9
11111.........................................-2
Als Lösung Ab N2:
Ab Spalte N2(Artik-Nr.) ..... ab O2(Gesm-Werte)
11111.............................................8
44444.............................................-2
88888............................................10
.......................................................16 Gesamt
das was ich probiert habe tut das nicht richt bzw. es ist ungenau.
Mein Versuch von Kluas Code:
Sub Liste_Auswerten_ausSP_A_und_SP_F()
' Geschrieben von Klaus-Dieter Oppermann, Oktober 2005
'Variablen deklarieren
Dim iZiel As Integer ' Letzte gefüllte Zelle
Dim az As Integer ' Zähler für Arrayfelder
Dim i As Integer ' Schleifenzähler (Arrays füllen)
Dim t As Integer ' Schleifenzähler (Gesamtpreise und Gesamtanzahl _
ermitteln)
Dim arr() As Variant ' Array für Artikelausgabe
Dim arr2() As Variant ' Array für Einzelpreisausgabe
Dim arr3() As Variant ' Array für Einzelpreisausgabe
iZiel = range("A16000").End(xlUp).Row ' Letzte gefüllte Zelle ermitteln (in Spalte A)
' Arrays dimensionieren
ReDim arr(iZiel, 0) ' Artikel
ReDim arr2(iZiel, 0) ' Einzelpreise
ReDim arrA(iZiel, 0) ' Einzelpreise
' Arrays mit Werten füllen
For i = 2 To UBound(arr) ' laufe von Zeile 2 bis _
_
Tabellenende
If Application.WorksheetFunction.CountIf(range(Cells(i, 1), _
Cells(1, 1)), Cells(i, 1).Value) = 1 Then ' wenn Artikel das _
erste Mal vorkommt, dann ...
arr(az, 0) = Cells(i, 1).Value ' ... Name in Array _
einlesen
arr2(az, 0) = Cells(i, 2).Value2 ' ... Einzelpreis in _
Array einlesen
'arrA(az, 0) = Cells(i, 2).Value3 ' ... Einzelpreis in _
_
Array einlesen
az = az + 1 ' ... Zähler für _
Arrayfeld plus 1
End If ' Ende der Auswertung
Next i ' Schleifenzähler plus _
_
1
' Inhalte ausgeben
range("N2", "N" & UBound(arr)) = arr ' Artikelnamen in _
Ausgabebereich schreiben
With range("O2", "P" & UBound(arr)) ' Ausgabbereich für _
Beträge
' .NumberFormat = "#,##0.00 $" ' Währungsformat _
festlegen
.Value = arr2 ' Beträge eintragen
'.Value = arr3 ' Beträge eintragen
End With ' Ende des Eintrags
For t = 2 To az + 1 ' laufe von Zeile 2 bis _
_
Listenende
Cells(t, 15) = Application.WorksheetFunction.SumIf(range _
(Cells(16000, 1), Cells(1, 1)), Cells(t, 14), range("F2:F16000")) ' Gesamtmenge _
berechnen
'Cells(t, 7) = Cells(t, 8) * Cells(t, 6) ' Gesamtpreis _
berechnen
Next t ' Schleifenzähler plus _
_
1
Columns("N:P").EntireColumn.AutoFit ' Spalten auf optimale _
_
Breite
End Sub
Ich hoffe mein Problemm wurde richtig beschrieben.
Besten Dank für allfällige Hilfe!
Daniel