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
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
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
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:
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
Moin,
dann erstelle doch einfach die Variable dazu am Anfang des Codes:
Dim arrX()
Hallo Angelina,
nimm einfach die funktionierende 1. Version.
Die 2. hat Atilla "versemmelt". Entweder hat er da zuviel oder zu wenig entfernt.
Gruß Uwe
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.
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.
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
hallo lieber atilla,
Zitat: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