Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

VBA - Gruppen erstellen und Zahlen darin verteilen ?
#1
Hallo an alle,

ich habe eine Beispiel-Mappe gemacht.

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

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

Vorab kann ich nur nochmals danke sagen

Angelina


Angehängte Dateien
.xls   Zahlen in Gruppen verteilen.xls (Größe: 332 KB / Downloads: 11)
Antworten Top
#2
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
Gruß Atilla
[-] Folgende(r) 1 Nutzer sagt Danke an atilla für diesen Beitrag:
  • Angelina
Antworten Top
#3
hallo atilla,

:18:

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


:23:
Ich verneige mich vor dir

Laola

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
Antworten Top
#4
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:
Gruß Atilla
[-] Folgende(r) 1 Nutzer sagt Danke an atilla für diesen Beitrag:
  • Angelina
Antworten Top
#5
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
Antworten Top
#6
Moin,
dann erstelle doch einfach die Variable dazu am Anfang des Codes:

Dim arrX()
Mit freundlichen Grüßen  :)
Michael
Antworten Top
#7
Hallo Angelina,

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

Gruß Uwe
Antworten Top
#8
Hallo zusammen,

(02.02.2015, 08:54)Kuwer schrieb: Hallo Angelina,

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

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. Sleepy
Gruß Atilla
[-] Folgende(r) 1 Nutzer sagt Danke an atilla für diesen Beitrag:
  • Angelina
Antworten Top
#9
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
Antworten Top
#10
hallo lieber atilla,


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

Wubsmiley

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
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste