AW: "Suchrichtung" in SpecialCells Range f. validation
08.01.2009 00:37:00
Erich
Hallo Andreas,
in der folgenden Prozedur werden die Zeilen- und Spaltennr. der gefundenen Zellen sortiert und dann
die Zellen in der wohl gewünschten Reihenfolge angesprungen:
Option Explicit
Sub ZellenFinden2()
Dim SuchRange As Range, rngF As Range, rngC As Range
Dim arrZS(), lngA As Long, lngC As Long
Set SuchRange = Range(Cells(1, 1), Cells(50, 50))
Set rngF = SuchRange.SpecialCells(xlCellTypeAllValidation)
If Not rngF Is Nothing Then
ReDim arrZS(1 To rngF.Cells.Count, 1 To 2)
For Each rngC In rngF
If rngC.Validation.InputMessage "" Then
lngA = lngA + 1
arrZS(lngA, 1) = rngC.Row
arrZS(lngA, 2) = rngC.Column
End If
Next rngC
If lngA > 0 Then
ReDim Preserve arrZS(1 To lngA, 1 To 2)
prcQuicksort Array(1, 2), arrZS()
For lngC = 1 To lngA
Cells(arrZS(lngC, 1), arrZS(lngC, 2)).Select
Application.Wait Now + TimeSerial(0, 0, 3)
Next lngC
Else
MsgBox "Nix gefunden."
End If
Else
MsgBox "Nix gefunden."
End If
End Sub
' Sort-Code kann in einem eigenen Modul stehen:
Option Explicit
' Code Max Kaffl (Nepumuk) 2005
'Quicksort mit mehreren Sortierkriterien
' Parameter: arrK = Sortkey(s)
' arrD = zu sortierendes Array
'Der Sortierschlüssel ist ein Array mit minimal einem Eintrag,
' der erste Eintrag gibt die Spalte mit dem obersten Sortierkriterium an.
' Ist die Zahl positiv, wird aufsteigend, sonst absteigend sortiert.
Sub prcQuicksort(arrK As Variant, arrD() As Variant)
Dim iiK As Integer, nnB As Long, nnC As Long, nArrZ() As Long
Dim nnZ As Long, nnA As Long, vntTemp As Variant
ReDim nArrZ(0 To 1, 0 To UBound(arrD) * 2)
nArrZ(0, 0) = LBound(arrD) ' Array für den 1. Sortierlauf
nArrZ(0, 1) = UBound(arrD)
nnZ = 1
For iiK = LBound(arrK) To UBound(arrK)
If arrK(iiK) 0 Then ' Wenn eine Spalte angegeben
nnA = -1
For nnB = 0 To nnZ Step 2 ' Schleife zum sortieren der Bereiche
If nArrZ(0, nnB) nArrZ(0, nnB + 1) Then ' Sortieren, wenn Zeilenzahl > 1
Call prcQSort(CLng(nArrZ(0, nnB)), _
CLng(nArrZ(0, nnB + 1)), CInt(Abs(arrK(iiK))), _
CBool(arrK(iiK) > 0), arrD())
nnA = nnA + 2 ' sortierten Bereich merken
nArrZ(1, nnA - 1) = nArrZ(0, nnB)
nArrZ(1, nnA) = nArrZ(0, nnB + 1)
End If
Next
nnZ = -1
For nnB = 0 To nnA Step 2 'Durchsuchen der sortierten Spalte nach Wertewechsel
vntTemp = arrD(nArrZ(1, nnB), Abs(arrK(iiK))) '1. Zeile des zu sort. Bereichs
nnZ = nnZ + 1
nArrZ(0, nnZ) = nArrZ(1, nnB)
For nnC = nArrZ(1, nnB) To nArrZ(1, nnB + 1) ' Suche nach Wechsel im Bereich
If vntTemp arrD(nnC, Abs(arrK(iiK))) Then
nnZ = nnZ + 2
nArrZ(0, nnZ - 1) = nnC - 1
nArrZ(0, nnZ) = nnC
vntTemp = arrD(nnC, Abs(arrK(iiK)))
End If
Next
nnZ = nnZ + 1 ' letzte Zeile im Bereich
nArrZ(0, nnZ) = nArrZ(1, nnB + 1)
Next nnB
End If
Next iiK
End Sub
Private Sub prcQSort(lngLB As Long, lngUB As Long, iiZ As Integer, _
bAufAb As Boolean, arrD())
Dim iiK As Integer, nnB As Long, nnC As Long, vntTemp As Variant, vntBuffer As Variant
nnB = lngLB
nnC = lngUB
vntBuffer = arrD((lngLB + lngUB) \ 2, iiZ)
Do
If bAufAb Then
Do While arrD(nnB, iiZ) vntBuffer: nnB = nnB + 1: Loop
Do While vntBuffer > arrD(nnC, iiZ): nnC = nnC - 1: Loop
End If
If nnB arrD(nnC, iiZ) Then
For iiK = LBound(arrD, 2) To UBound(arrD, 2)
vntTemp = arrD(nnB, iiK)
arrD(nnB, iiK) = arrD(nnC, iiK)
arrD(nnC, iiK) = vntTemp
Next
End If
nnB = nnB + 1
nnC = nnC - 1
ElseIf nnB = nnC Then
nnB = nnB + 1
nnC = nnC - 1
End If
Loop Until nnB > nnC
If lngLB
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort