AW: VBA SpaltenVergleich
02.02.2015 08:01:35
Oberschlumpf
hmm, du verarschst mich...
ok, ich helf dir trotzdem, aber
Eigentlich bin ich auch als Antworter ein großer Fan von Excel-Dateien, in denen funktionsfähig mein Code eingetragen ist.
Bei dir mach ich mal ne Ausnahme.
Und vorher noch n Hinweis auf etwas, was nicht zusammen passt:
Du schreibst in Tabelle1:
Nur Zahlen-Kombinatioen ab drei Übereinstimmungen
Dann stimmt aber deine Ergebnisliste in Tabelle1 nicht.
Z Bsp die Zahlen 455 + 456 sind in der Bsp-Tabelle nur 2x eingetragen.
Wieso erscheinen sie in der Ergebgnistabelle, wenn jede Zahl doch mind. 3x eingetragen sein muss?
Schlussendlich dürfen nach Vorgabe "nur bei 3 Übereinstimmungen" nur die Zahlen 243, 633 + 759 in der Ergebnisliste erscheinen, was mit meinem Code auch geliefert wird.
So, nun zur Funktionsweise meines Codes:
1. zuerst wird der definierte Zellbereich, hier "E12:L17", Zelle für Zelle untereinander in die Hilfsspalte "AB" übertragen
2. dann werden alle eingetragenen Werte in AB aufsteigend sortiert
3. dann werden alle Werte, die mind. 3x gleich sind, in eine Array-Variable (AV) eingelesen
4. vor dem Einlesen in die AV wird jedes mal geprüft, ob ein Wert nicht schon eingetragen ist
So wird sichergestellt, dass jeder Wert wirklich nur 1x in der AV eingetragen ist
5. nun werden alle Werte aus der AV in die Ergebnisliste übertragen
Dabei wird darauf geachtet, wenn, bei T14 beginnend, Y14 erreicht wird, dass die nächsten, möglichen Werte ab T15 ff. eingetragen werden
6. im letzten Schritt wird die Hilfsspalte AB vollständig gelöscht
Hier nun der Code:
Wichtig!!
Die Forumssoftware fügt leider bei zu breit geratenen Codezeilen Zeilenumbrüche ein, damits hier im Forum immer "schön" aussieht.
Das kann aber zur Folge haben, dass der Code, wenn 1:1 kopiert + im VBE eingefügt, nicht mehr funktioniert.
Du musst also drauf achten, dass "falsche" Zeilenumbrüche im VBE von dir entfernt werden.
Hilfts denn?
Sub sb3fach()
Dim lloRow As Long, lloCol As Long, lrgCell As Range, liMore2 As Integer, larMore2() As _
Variant, liIdx As Integer, lboNotOk As Boolean
lloRow = 1
ReDim larMore2(0)
With Sheets(2)
For Each lrgCell In .Range("E12:L17") 'Range anpassen
.Range("AB" & lloRow).Value = lrgCell.Value 'Hilfsspalte AB anpassen, wenn _
erforderlich
lloRow = lloRow + 1
Next
.Range("AB1:AB" & .Cells(Rows.Count, 28).End(xlUp).Row).Sort Key1:=.Range("AB1"), _
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For lloRow = 1 To .Cells(Rows.Count, 28).End(xlUp).Row
If .Range("AB" & lloRow).Value = .Range("AB" & lloRow + 1).Value Then
liMore2 = liMore2 + 1
If liMore2 >= 2 Then
For liIdx = 0 To UBound(larMore2)
If larMore2(liIdx) = .Range("AB" & lloRow).Value _
Then
lboNotOk = True
Exit For
End If
Next
If lboNotOk = False Then
larMore2(UBound(larMore2)) = .Range("AB" & _
lloRow).Value
ReDim Preserve larMore2(UBound(larMore2) + 1)
Else
lboNotOk = False
End If
liMore2 = 0
End If
Else
liMore2 = 0
End If
Next
ReDim Preserve larMore2(UBound(larMore2) - 1)
lloRow = 14
lloCol = 20
.Range("T14:Y15").Value = ""
For liIdx = 0 To UBound(larMore2)
.Cells(lloRow, lloCol).Value = larMore2(liIdx)
lloCol = lloCol + 1
If lloCol = 26 Then
lloCol = 20
lloRow = lloRow + 1
End If
Next
.Columns("AB:AB").Delete Shift:=xlToLeft
End With
End Sub
Ciao
Thorsten