AW: Sortieren
07.10.2017 11:31:17
Peter
Hallo Hajo,
hier die verbesserte Version der VBA Lösung.
Sie unterstützt auch mehrere Einträge gleicher Art in der Tabelle der Kostenstellen.
Gruß Peter
'
' diese Version bildet auch doppelte Einträge ab
Public Sub Nach_Kostenstelle_I()
Dim Mydict_Kreise As Object ' das Dictionary der Kreise
Dim Mydict_Quadrate As Object ' das Dictionary der Quadrate
Dim Mydict_Dreiecke As Object ' das Dictionary der Dreiecke
Dim vTemp As Variant ' das temporäre Array der Eingabewerte
Dim vItems As Variant ' das temporäre Array für die Bezeichnung
Dim lZeile As Long ' die Zeile im Array der Eingabewerte
Dim Kostst As Variant ' die Kostenstelle
Set Mydict_Kreise = CreateObject("Scripting.Dictionary") ' die Dictionary Variable _
benennen
Set Mydict_Quadrate = CreateObject("Scripting.Dictionary") ' die Dictionary Variable _
benennen
Set Mydict_Dreiecke = CreateObject("Scripting.Dictionary") ' die Dictionary Variable _
benennen
Application.ScreenUpdating = False ' kein Bildschirm Update zulassen
With ThisWorkbook.Worksheets("Tabelle1") ' den Tabellenblattnamen ggf. anpassen!
vTemp = .Range("G3:H" & .Cells(.Rows.Count, 7).End(xlUp).Row) ' die Eingabe als Array _
speichern
For lZeile = LBound(vTemp, 1) To UBound(vTemp, 1) ' den Array abarbeiten
If vTemp(lZeile, 2) "" Then ' ist die kostenstelle nicht leer?
Select Case LCase(vTemp(lZeile, 2)) ' die Bezeichnung als Kennzeichen verwenden
Case "kreis"
Mydict_Kreise(vTemp(lZeile, 1) & "##" & vTemp(lZeile, 2)) = _
Mydict_Kreise(vTemp(lZeile, 1) & "##" & vTemp(lZeile, 2)) + 1 ' _
Kostenstelle Werte Kreise ermitteln
Case "quadrat"
Mydict_Quadrate(vTemp(lZeile, 1) & "##" & vTemp(lZeile, 2)) = _
Mydict_Quadrate(vTemp(lZeile, 1) & "##" & vTemp(lZeile, 2)) + 1 ' _
Kostenstelle Werte Quadrate ermitteln
Case "dreieck"
Mydict_Dreiecke(vTemp(lZeile, 1) & "##" & vTemp(lZeile, 2)) = _
Mydict_Dreiecke(vTemp(lZeile, 1) & "##" & vTemp(lZeile, 2)) + 1 ' _
Kostenstelle Werte Dreiecke ermitteln
End Select
End If
Next lZeile ' die nächste Zeile verarbeiten
Range("C3:E8").ClearContents ' die Ausgabespalten löschen
vTemp = Mydict_Kreise.keys ' den Dictionary Array an einen allgemeinen Array übergeben
vItems = Mydict_Kreise.items ' den Dictionary Array an einen allgemeinen Array übergeben
For lZeile = LBound(vTemp) To UBound(vTemp) ' den allgemeinen Array abarbeiten
Kostst = Split(vTemp(lZeile), "##") ' am Wert "##" aufteilen/splitten
Select Case Kostst(0) ' die Kostenstelle abfragen
Case "10": Range("C3").Value = vItems(lZeile) ' den Inhalt des allgemeinen Arrays _
ausgeben
Case "11": Range("C4").Value = vItems(lZeile)
Case "12": Range("C5").Value = vItems(lZeile)
Case "13": Range("C6").Value = vItems(lZeile)
Case "14": Range("C7").Value = vItems(lZeile)
Case "15": Range("C8").Value = vItems(lZeile)
End Select
Next lZeile
vTemp = Mydict_Quadrate.keys
vItems = Mydict_Quadrate.items
For lZeile = LBound(vTemp) To UBound(vTemp)
Kostst = Split(vTemp(lZeile), "##")
Select Case Kostst(0)
Case "10": Range("D3").Value = vItems(lZeile)
Case "11": Range("D4").Value = vItems(lZeile)
Case "12": Range("D5").Value = vItems(lZeile)
Case "13": Range("D6").Value = vItems(lZeile)
Case "14": Range("D7").Value = vItems(lZeile)
Case "15": Range("D8").Value = vItems(lZeile)
End Select
Next lZeile
vTemp = Mydict_Dreiecke.keys
vItems = Mydict_Dreiecke.items
For lZeile = LBound(vTemp) To UBound(vTemp)
Kostst = Split(vTemp(lZeile), "##")
Select Case Kostst(0)
Case "10": Range("E3").Value = vItems(lZeile)
Case "11": Range("E4").Value = vItems(lZeile)
Case "12": Range("E5").Value = vItems(lZeile)
Case "13": Range("E6").Value = vItems(lZeile)
Case "14": Range("E7").Value = vItems(lZeile)
Case "15": Range("E8").Value = vItems(lZeile)
End Select
Next lZeile
End With
Set Mydict_Kreise = Nothing ' die Ressourcen freigeben
Set Mydict_Quadrate = Nothing
Set Mydict_Dreiecke = Nothing
End Sub
