VBA - Gruppen erstellen und Zahlen darin verteilen ?

[Angelina]

Hallo an alle,

ich habe eine Beispiel-Mappe gemacht.

Es sollen Zahlen-Gruppen gebildet und die dazugehörigen Werte darin
verteilt werden.

Hätte vielleicht jemand eine Idee / Lust / Zeit mir das in VBA zu schreiben?

Vorab kann ich nur nochmals danke sagen

Angelina

[atilla]

Hallo Angelina,

schöne und interessante Aufgaben, die Du uns hier stellst.
Dann teste mal:

Code:

Option Explicit

Sub test()
   Dim i As Long, j As Long, k As Long, x As Long
   Dim lngZ As Long
   Dim varKey
   Dim varFeld1, varFeld2, arrX
   Dim arr1(), arr2()
   Dim objDic As Object
  
   varFeld1 = Range("ER1:GA1")
   varFeld2 = Range("ER2:GA2")
   Set objDic = CreateObject("Scripting.Dictionary")
  
   For j = 1 To 36
      varKey = varFeld2(1, j)
      If varFeld2(1, j) <> "" And InStr(objDic(varKey), varFeld2(1, j) & "##" & varFeld1(1, j)) = 0 Then
          objDic(varKey) = objDic(varKey) & "##" & varFeld1(1, j)
      End If
   Next j
  
   j = 0
    ReDim arr1(objDic.Count - 1)
    ReDim arr2(objDic.Count - 1, 35)
    For Each varKey In objDic
        arrX = Split(RTrim(objDic(varKey)), "##")
        x = UBound(Split(RTrim(objDic(varKey)), "##"))
        arr1(j) = varKey
        For i = 1 To x
         arr2(j, k) = arrX(i)
         k = k + 1
        Next i

         k = 0
        j = j + 1
    Next varKey
    
    lngZ = Application.Max(Cells(Rows.Count, 147).End(xlUp).Row, 4)
    Range("EQ4:GA" & lngZ).ClearContents
    Range("EQ4:EQ" & j + 3) = "Gruppe"
    Range("ER4:ER" & j + 3) = Application.Transpose(arr1)
    Range("ET4:GA" & j + 3) = arr2
    Range("EQ4:GA" & j + 3).Sort Key1:=Range("ER4"), Order1:=xlAscending, Header:=xlNo, _
           OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
           DataOption1:=xlSortNormal

End Sub

[Angelina]

hallo atilla,

:18:

Du bist wirklich der Hammer - sofort - fehlerfrei
wie kann man nur soviel wissen? :75:


:23:
Ich verneige mich vor dir



Ich bin dir nochmals sehr sehr sehr dankbar für deine Mühe

PS: Ich darf ja nicht soviel danke sagen, Gruß an deine Frau :100:


DANKE

Angelina

[atilla]

Hallo Angelina,

der Code funktioniert zwar, aber da sind doch einige Dinge überflüssig und
einiges kann man noch zusammenfassen.

deshalb und weil Du Dich immer so nett bedankst, habe ich hier eine verbesserte und abgespeckte Version:

Code:

Option Explicit

Sub test()
   Dim i As Long, j As Long, k As Long
   Dim lngZ As Long
   Dim varKey
   Dim varFeld1
   Dim arr1()
   Dim objDic As Object
  
   varFeld1 = Range("ER1:GA2")
   Set objDic = CreateObject("Scripting.Dictionary")
  
   For j = 1 To 36
      varKey = varFeld1(2, j)
      If varFeld1(2, j) <> "" And InStr(objDic(varKey), varFeld1(2, j) & "##" & varFeld1(1, j)) = 0 Then
          objDic(varKey) = objDic(varKey) & "##" & varFeld1(1, j)
      End If
   Next j
  
   j = 0
    ReDim arr1(objDic.Count - 1, 36)
    For Each varKey In objDic
        arr1(j, 0) = varKey
        For i = 1 To UBound(Split(objDic(varKey), "##"))
            arr1(j, k + 2) = arrX(i)
            k = k + 1
        Next i
         k = 0
         j = j + 1
    Next varKey
    
    lngZ = Application.Max(Cells(Rows.Count, 147).End(xlUp).Row, 4)
    Range("EQ4:GA" & lngZ).ClearContents
    Range("EQ4:EQ" & j + 3) = "Gruppe"
    Range("ER4:GA" & j + 3) = arr1
    Range("EQ4:GA" & j + 3).Sort Key1:=Range("ER4"), Order1:=xlAscending, Header:=xlNo, _
           OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
           DataOption1:=xlSortNormal

End Sub

Übrigens, man kann Dir punktgenaue Vorschläge machen, weil deine Erklärungen auch punktgenau sind. Das ist selten, dass der Fragesteller die Problemstellung so detailliert und für den Helfer verständlich darstellt. :28:

[Angelina]

hallo atilla,

erstmal muß ich mich entschuldigen, das ich erst jetzt antworte.

Ich habe keine Info vom Forum bekommen das eine neue Nachricht da ist.
Hatte vergessen abonnieren anzuklicken.

Bitte - Bitte entschuldige dies - es ist wirklich nicht meine Art - umgehend zu antworten.

Danke dir das du dir soviel Mühe machst. Ich habe deinen neuen VBCode eben mal testen wollen
da bekomme ich die Meldung "Sub oder Funktion nicht definiert" und zwar hier:

arrX

Nochmals bitte um entschuldigung!

Ganz liebe Grüße

Angelina

[Zwergel]

Moin,
dann erstelle doch einfach die Variable dazu am Anfang des Codes:

Dim arrX()

[Kuwer]

Hallo Angelina,

nimm einfach die funktionierende 1. Version.
Die 2. hat Atilla "versemmelt". Entweder hat er da zuviel oder zu wenig entfernt.

Gruß Uwe

[atilla]

Hallo zusammen,

Hallo Angelina,

nimm einfach die funktionierende 1. Version.
Die 2. hat Atilla "versemmelt". Entweder hat er da zuviel oder zu wenig entfernt.

Uwe, das siehst Du völlig richtig. Da habe ich etwas zu viel weggeputzt.


Angelina ersetz bitte

arrX(i)

mit diesem Ausdruck

Split(objDic(varKey), "##")(i)

und es sollte wieder problemlos laufen.
Wenn nicht, dann halte Dich bitte an den Rat von Uwe..... und vergiss mich.

[Angelina]

hallo Uwe,
hallo Zwergel

danke auch euch für die Rückmeldung.

Ich warte mal ab was atilla noch für eine Rückmeldung gibt.

Derzeit verwende ich dann noch Vorschlag 1

Er hat sich sooooooviel Mühe gemacht - bin dafür sehr dankbar :23:

Tolles Forum und alle sind wirklich sehr nett :28:

LG
Angelina

[Angelina]

hallo lieber atilla,

und es sollte wieder problemlos laufen.
Wenn nicht, dann halte Dich bitte an den Rat von Uwe..... und vergiss mich.

Nein - niemals !!!

Habe deine zweite Version nun in Verwendung und getestet - gleiche Ergebnisse wie die Version 1
alles perfekt - wie immer :18:

Danke danke für deine Mühe

LG
Angelina