AW: Teilergebnisse in VBA mit Spalteninformationen
11.10.2005 20:07:59
Klaus-Dieter
Hallo Gerry,
versuche es mal damit:
Option Explicit
Sub liste_auswerten()
' findet in einer Liste, die nicht sortiert sein muss
' alle vorkommenden Artikel. Diese werden mit der Gesamtanzahl
' in einer neuen Liste ausgegeben.
' 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 ermitteln)
Dim arr() As Variant ' Array für Song
Dim arr1() As Variant ' Array für Compuser
iZiel = Worksheets("Tabelle1").Range _
("A65536").End(xlUp).Row ' Letzte gefüllte Zelle ermitteln (in Spalte A)
' Arrays dimensionieren
ReDim arr(iZiel, 0) ' Song
ReDim arr1(iZiel, 0) ' Compuser
' Arrays mit Werten füllen
For i = 2 To UBound(arr) ' laufe von Zeile 2 bis Tabellenende
If Application.WorksheetFunction.CountIf(Range(Worksheets _
("Tabelle1").Cells(i, 1), Worksheets("Tabelle1").Cells(1, 1)) _
, Worksheets("Tabelle1").Cells(i, 1).Value) = 1 Then ' wenn Artikel das erste Mal vorkommt, dann ...
arr(az, 0) = Worksheets("Tabelle1").Cells(i, 1).Value ' ... Name in Array einlesen
arr1(az, 0) = Worksheets("Tabelle1").Cells(i, 2).Value ' ... Name 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
Worksheets("Tabelle2").Range("A2", "A" & UBound(arr)) = arr ' Artikelnamen in Ausgabebereich schreiben
Worksheets("Tabelle2").Range("B2", "B" & UBound(arr)) = arr1 ' Artikelnamen in Ausgabebereich schreiben
For t = 2 To az + 1 ' laufe von Zeile 2 bis Listenende
Worksheets("Tabelle2").Cells(t, 3) = Application.WorksheetFunction. _
SumIf(Range(Worksheets("Tabelle1").Cells(iZiel, 1), Worksheets _
("Tabelle1").Cells(2, 1)), Worksheets("Tabelle1").Cells(t, 5), _
Worksheets("Tabelle1").Range("C2", "C" & iZiel)) ' Gesamtmenge berechnen
Next t ' Schleifenzähler plus 1
With Range("C2", "C" & az) ' Bereich definieren
.NumberFormat = "#,##0.00 " ' Euroformat setzen
End With
Worksheets("Tabelle2").Columns("A:C").EntireColumn.AutoFit ' Spalten auf optimale Breite
End Sub
Viele Grüße Klaus-Dieter
Online-Excel