Ein Freund hat mir 2 Makros geschrieben womit man Zahlen in allen Spalten in bestimmter Reihenfolge unter Millionen von Zahlen findet.
Da die Zahlen öfters in richtiger Reihenfolge vorkommen werden Sie dann in einem eigenen Tabellenblatt angezeigt.
Es sieht dann so Aus:
In Blatt 1 sind meine Zahlen (Mehrere Millionen)
In Blatt 2 werden die gesuchten Zahlen eingegeben
In Blatt 3 werden die gefunden Zahlen kopiert und Farblich angezeigt
Korrekt abgelaufes Makro sah dann z.B so aus
18
47
95
18
Die 4 Nummern wurden in Blatt 2 eingegen zum Suchen
-----------------------------------------------------------------
Nach dem durchsuchen von den Millionen von Zahlen wurde im Blatt 3 dies angezeigt.
32
85 Die 3 Vornummer
82
18
47
95 Die 4 Nummer wurden in Blatt 2 eingegen zum Suchen
18
41
17
96
99 Die 8 Nachnummern
64
72
87
43
Angezeigt werden die 4 gesuchten Nummern inklusive
3 Vor und 8 Nachnummern
--------------------------------------------------------------------
Da wir nun Verschiedener Meinung sind hat er mir die Makros ohne mein Wissen so umgeschrieben das sie nun bedingt
richtig Arbeiten.
Mann kann jetzt nur 3 Nummern
suchen und nicht mehr 4 oder Mehr.
Er zeigt mir zwar die gefundenen Zahlen an aber nicht mehr alle sondern kopiert das Ergebniss x-mal(unsinniger Weise) in Blatt 3
Könnte sich vielleicht jemand die Makros anschauen und Sie wieder "entsperren" das sie korrekt arbeiten.
Das korrekt Makro müsste so ablufen.
Durchsucht Blatt 1 nach den eingebeben Such-Zahlen aus Blatt 2
Wenn Zahlen in richtiger Reihenfolge gefunden werden (auch mehrere)
dann in Blatt 3 angezeigt mit 3 Vor und 8 Nachnummern.
--------------------------------------------------------------------------
Hier die Makros-
Option Explicit
Sub SetStrings()
Dim rng As Range
Dim iCol As Integer
Dim lRow As Long, lRowL As Long
Dim iColT As Integer, iCount As Integer
On Error GoTo ERRORHANDLER
Application.EnableCancelKey = xlErrorHandler
Application.Calculation = xlCalculationManual
Set rng = Worksheets(2).Range("A1").CurrentRegion
iCount = rng.Rows.Count
iCol = 1
Do While WorksheetFunction.CountA(Columns(iCol)) > 0
Columns(52 + iCol).ClearContents
If Not IsEmpty(Cells(1048576, iCol)) Then
lRowL = 1048576 - iCount + 1
Else
lRowL = Cells(Rows.Count, iCol).End(xlUp).Row - iCount + 1
End If
Cells(1, 52 + iCol).FormulaR1C1 = "=RC" & CStr(iCol) & "&"";""&R[1]C" & CStr(iCol) & "&"";""&R[2]C" & CStr(iCol)
With Range(Cells(1, 52 + iCol), Cells(lRowL, 52 + iCol))
.FillDown
.Calculate
.Value = .Value
End With
iCol = iCol + 1
Loop
Call TransferData
ERRORHANDLER:
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End Sub
-----------------------------------------------------------------------------------
Sub TransferData()
Dim wksA As Worksheet, wksB As Worksheet
Dim rng As Range
Dim vColor As Variant
Dim lStart As Long, lEnd As Long
Dim iCol As Integer, iRow As Integer, iCount As Integer, iColT As Integer
Dim sTxt As String, sAddress As String
Set wksA = Worksheets(2)
Set wksB = Worksheets(3)
wksB.Cells.Clear
iCount = WorksheetFunction.CountA(wksA.Columns(1))
If iCount = 3 Then vColor = vbYellow Else vColor = vbCyan
For iRow = 1 To iCount
sTxt = sTxt & wksA.Cells(iRow, 1).Value & ";"
Next iRow
sTxt = Left(sTxt, Len(sTxt) - 1)
iCol = 53
Do While WorksheetFunction.CountA(Columns(iCol)) > 0
Set rng = Cells(1, iCol)
Set rng = Columns(iCol).Find( _
what:=sTxt, _
lookat:=xlWhole, _
LookIn:=xlValues, _
MatchCase:=False, _
after:=rng)
If Not rng Is Nothing Then
sAddress = rng.Address
If rng.Row < 4 Then lStart = 1 Else lStart = rng.Row - 3
If rng.Row > 1048576 - 13 Then lEnd = 1048576 Else lEnd = rng.Row + iCount + 7
iColT = WorksheetFunction.CountA(wksB.Rows(1)) + 1
wksB.Range(wksB.Cells(1, iColT), wksB.Cells(lEnd - lStart + 1, iColT)).Value = Range(Cells(lStart, iCol - 52), Cells(lEnd, iCol - 52)).Value
wksB.Range(wksB.Cells(4, iColT), wksB.Cells(4 + iCount - 1, iColT)).Interior.Color = vColor
Range(Cells(rng.Row, iCol - 52), Cells(rng.Row + iCount - 1, iCol - 52)).Interior.Color = vColor
rng.Offset(1).Select
Do
Columns(iCol).FindNext(after:=ActiveCell).Activate
If ActiveCell.Address = sAddress Then
Columns(iCol).ClearContents
Exit Do
End If
iColT = WorksheetFunction.CountA(wksB.Rows(1)) + 1
If ActiveCell.Row < 4 Then lStart = 1 Else lStart = rng.Row - 3
If ActiveCell.Row > 1048576 - 13 Then lEnd = 1048576 Else lEnd = rng.Row + iCount + 7
wksB.Range(wksB.Cells(1, iColT), wksB.Cells(lEnd - lStart + 1, iColT)).Value = Range(Cells(lStart, iCol - 52), Cells(lEnd, iCol - 52)).Value
wksB.Range(wksB.Cells(4, iColT), wksB.Cells(4 + iCount - 1, iColT)).Interior.Color = vColor
Range(Cells(ActiveCell.Row, iCol - 52), Cells(ActiveCell.Row + iCount - 1, iCol - 52)).Interior.Color = vColor
Loop
End If
Columns(iCol).ClearContents
iCol = iCol + 1
Loop
Range("A1").Select
Application.Goto wksB.Range("A1"), True
End Sub
---------------------------------------------------------
Vielleicht kann mir ja jemand weiterhelfen
lg
Andi
