AW: Okay, dann teste mal...
25.04.2017 16:36:30
Michael
Hallo Jens!
Zunächst: So eine Entschuldigung hätte es nicht gebraucht ;-), es hat mich einfach nur geärgert, Danke dafür! Aber, ich war nicht untätig, obwohl mich Deine neuen Anforderungen schon vor eine Herausforderung gestellt haben - das war jetzt doch knifflig (zumindest für mich)...
Zuerst ein paar Anmerkungen zum Code:
- Ich hab ihn auf Basis Deines "Beispiel in klein" getestet; das klappt aus meiner Sicht, aber Du musst trotzdem einen vollen Test mit Deinen Originaldaten machen
- Der Code läuft jetzt neu auf dem aktiven Blatt, nicht mehr auf einem bestimmten (zB "Tabelle1"), d.h. Du musst zunächst sicherstellen, dass das betroffene Blatt auch aktiv ist, bevor Du den Code ausführst.
- Deine Bereichsangaben ("Matrizen") musst Du noch einpflegen, es sind aktuell nur die vom kleinen Bsp. drinnen
- Anders als bei Deinem kleinen Bsp hab ich jetzt für die Zielspalte wieder Spalte D, ab D12 angenommen (wie in Deinem Ursprungsbeitrag)
- Es braucht in diesem (neuen) Fall einen wesentlich erweiterten Code (insgesamt 2 Subs) - bitte beide einfach in ein allgemeines Modul einfügen; starten musst Du nur "Sub c"
Teste mal, die Anforderungen waren schon eine Wucht ;-):
Sub c()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.ActiveSheet
Dim Matrizen As Range
Dim Dic As Object, RegEx As Object
Dim Zahlen, a, b, c, d, Sp
Dim i&, j&, k&, l&, m&, n&, o&, z&, s&, nZ&
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set RegEx = CreateObject("vbscript.regexp")
With Ws
Set Matrizen = Union(.Range("D2:G10"), .Range("I2:M10"))
For i = 1 To Matrizen.Areas.Count
a = Matrizen.Areas(i)
ReDim b(1 To Matrizen.Areas(i).Cells.Count)
For s = LBound(a, 2) To UBound(a, 2)
For z = LBound(a, 1) To UBound(a, 1)
If a(z, s) vbNullString Then
j = j + 1: b(j) = a(z, s)
If Not Dic.exists(Left(a(z, s), 1)) Then Dic.Add Left(a(z, s), 1), ""
End If
Next z
Next s
ReDim Preserve b(1 To j)
For k = 1 To j - 1
For l = k + 1 To j
If b(k) vbNullString And b(l) vbNullString Then
If Left(b(k), 1) = Left(b(l), 1) Then
With RegEx
.Pattern = "[0-9]{2,}"
.Global = True
End With
Set Zahlen = RegEx.Execute(b(k))
ReDim c(0 To Zahlen.Count - 1)
For m = 0 To Zahlen.Count - 1
c(m) = CInt(Zahlen(i))
Next m
Call QuickSort(c, LBound(c), UBound(c))
Set Zahlen = RegEx.Execute(b(l))
ReDim d(0 To Zahlen.Count - 1)
For m = 0 To Zahlen.Count - 1
d(m) = CInt(Zahlen(i))
Next m
Call QuickSort(d, LBound(d), UBound(d))
If c(UBound(c)) > d(UBound(d)) Then
b(k) = vbNullString
ElseIf d(UBound(d)) > c(UBound(c)) Then
b(l) = vbNullString
End If
Erase c: Erase d
End If
End If
Next l
Next k
For n = LBound(b) To UBound(b)
If b(n) vbNullString Then
If .Cells(.Rows.Count, 4).End(xlUp).Row High Then Exit Sub
vPartition = ArrayToSort((Low + High) \ 2)
i = Low: j = High
Do
Do While ArrayToSort(i) vPartition
j = j - 1
Loop
If i j
If (j - Low)
Gib Bescheid ob das zufriedenstellend läuft!
Michael