AW: Lösungsansatz
19.12.2005 14:58:24
Heiko
Hallo Timo,
hier mal ein VBA Ansatz, wobei ich nicht so ganz verstanden habe wie deine Liste aufgebaut ist.
Mein Beispiel setz eine Liste Vorraus:
Spalte A: Namen (die ruhig doppelt in Spalte A vorkommen können.)
Spalte B, C und D: Umsätze zu den Namen in Spalte A, es muss nicht überall was drin stehen.
Ergebniss ist eine Liste mit den Umsätzen zu allen vorkommenen Namen, wenn der Name in verschiedenen Zeilen auftaucht werden die Umsätze aus allen Zeilen aufaddiert.
Sub SummeDerNamen()
Dim lngI As Long, lngArrCounter As Long
Dim dblUmsatz As Double
Dim strOldName As String
Dim arrNamen() As String
Dim arrUmsatz() As Double
Application.ScreenUpdating = False
' **** Das Ausgangs Tabellenblatt anpassen ****
Sheets("TabelleMitNamen").Copy after:=Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Name = "Namen Zusammenfassung"
ActiveSheet.UsedRange.Sort Key1:=ActiveSheet.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
strOldName = ActiveSheet.Cells(1, 1)
For lngI = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
If ActiveSheet.Cells(lngI, 1).Text <> strOldName Then
ReDim Preserve arrNamen(lngArrCounter)
ReDim Preserve arrUmsatz(lngArrCounter)
arrNamen(lngArrCounter) = strOldName
arrUmsatz(lngArrCounter) = dblUmsatz
lngArrCounter = lngArrCounter + 1
dblUmsatz = ActiveSheet.Cells(lngI, 2) + ActiveSheet.Cells(lngI, 3) + ActiveSheet.Cells(lngI, 4)
strOldName = ActiveSheet.Cells(lngI, 1).Text
Else
dblUmsatz = dblUmsatz + ActiveSheet.Cells(lngI, 2) + ActiveSheet.Cells(lngI, 3) + ActiveSheet.Cells(lngI, 4)
End If
Next lngI
ReDim Preserve arrNamen(lngArrCounter)
ReDim Preserve arrUmsatz(lngArrCounter)
arrNamen(lngArrCounter) = strOldName
arrUmsatz(lngArrCounter) = dblUmsatz
ActiveSheet.Cells.Delete
ActiveSheet.Range("A1:A" & UBound(arrNamen) + 1) = Application.WorksheetFunction.Transpose(arrNamen)
ActiveSheet.Range("B1:B" & UBound(arrNamen) + 1) = Application.WorksheetFunction.Transpose(arrUmsatz)
Application.ScreenUpdating = True
End Sub
Gruß Heiko
PS: Rückmeldung wäre nett !