Betrag aufteilen, brauche Hilfe für Code

x = 0 ReDim Preserve Kostenstelle(x) Kostenstelle(x) = "101" For Each c In rngBereich If c.Value Kostenstelle(x) Then x = x + 1 ReDim Preserve Kostenstelle(x) Kostenstelle(x) = c.Value End If Next c

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub aaa() Dim objKstCount As Object, objKstLast As Object, rngC As Range, rngBereich As Range Dim arrKst, arrKeys, arrItems, i As Integer, j As Integer, tmp1, tmp2 Set objKstCount = CreateObject("scripting.dictionary") Set objKstLast = CreateObject("scripting.dictionary") Set rngBereich = Sheets(1).Range("A2:A1000") For Each rngC In rngBereich objKstCount(rngC.Value) = objKstCount(rngC.Value) + 1 'zählen objKstLast(rngC.Value) = rngC.Row 'letzte Zeile Next arrKeys = objKstCount.keys arrItems = objKstCount.items ReDim arrKst(1 To objKstCount.Count, 1 To 2) For i = 0 To UBound(arrKeys) arrKst(i + 1, 1) = arrKeys(i) arrKst(i + 1, 2) = arrItems(i) Next For i = 1 To UBound(arrKst) - 1 For j = i + 1 To UBound(arrKst) If arrKst(j, 2) > arrKst(i, 2) Then tmp1 = arrKst(i, 1) tmp2 = arrKst(i, 2) arrKst(i, 1) = arrKst(j, 1) arrKst(i, 2) = arrKst(j, 2) arrKst(j, 1) = tmp1 arrKst(j, 2) = tmp2 End If Next Next 'die letzen Positionen der 3 am häufigsten vorkommenden KSt Debug.Print objKstLast(arrKst(1, 1)) Debug.Print objKstLast(arrKst(2, 1)) Debug.Print objKstLast(arrKst(3, 1)) End Sub

Danke für deine Bemühungen!
Leider gibt es falsche werte aus.
Mein neuer Ansatz sieht so aus:


Sub TK_Anschluss()
Set wks = ThisWorkbook.Sheets("Daten")
With wks
lngZeile = .Range(.Cells(.Rows.Count, 5), .Cells(2, 5)).Find( _
What:="*", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:= _
xlByRows, SearchDirection:=xlPrevious).Row
Set rngBereich = .Range(.Cells(2, 5), .Cells(lngZeile, 5))
x = 0
ReDim Preserve lngCount(x)
lngCount(x) = 0
ReDim Preserve Kostenstelle(x)
Kostenstelle(x) = "1004"
For Each c In rngBereich
If c.Value = Kostenstelle(x) Then
lngCount(x) = lngCount(x) + 1
Else
x = x + 1
ReDim Preserve Kostenstelle(x)
ReDim Preserve lngCount(x)
Kostenstelle(x) = c.Value
End If
Next c
'For i = 0 To x
MsgBox WorksheetFunction.Max(lngCount)
'Next i
End With
End Sub

Ich habe dann zwar einen Zähler (lngCount), aber der ist nunmal auch in einem array.
Mit WorksheetFunction kann ich zwar den Max wert aus dem Array holen aber dann müsste es neu dimensioniert werden, der höchste wert müsste also raus und dass dann drei mal.
Soweit ich weiß kann man keine Werte einfach so aus einem Array Löschen, somit ist meine Variante keine Option

Beliebteste Forumthreads (12 Monate)

Betrag aufteilen, brauche Hilfe für Code

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Betrag aufteilen, brauche Hilfe für Code

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread