Probleme nach Suchscript
08.06.2020 09:57:54
Maik
ich weiß zwar nicht wie das funktioniert aber meinen alten Post kann ich nicht mehr beantworten.
https://www.herber.de/forum/cgi-bin/callthread.pl?index=1761750#1761750
Dort habe ich von Piet eine Suchfunktion bekommen. Dafür nochmal danke.
Falls das Script so schleckrig ist möchte ich gerne Piet in Schutz nehmen er hat nur ein bestehendes Script abgeändert.
Mein Problem ist es, wenn ich die Suchfunktion verwende markiere und springe ich zu dem Lehrgang. Dann muss ich ab und an mal eine Zeile einfügen um einen neuen Lehrgang anzulegen.
Wenn ich das mache bekomme ich eine Fehlermeldung das mein Arbeitsspeicher voll ist und die Operation nicht ausgeführt werden kann. Scrolle ich zu dem Lehrgang oder benutze die suche über Strg+F kann ich normal eine Zeile einfügen.
Es passiert immer nach dem ich die Suche über das Skript angestoßen habe.
Im Taskmanager ist mein Arbeitsspeicher aber auch nicht wirklich ausgelastet.
Ach so vorher kommt noch eine Warnmeldung das das eine Komplexe Operation und das diese abgebrochen wird wenn es länger als 60 sec dauert. Aber er meckert schon nach 5 sec.
Die suche soll alles in Spalte B nach der Lehrgangsnummer durchsuchen und die entsprechenden Zellen in Spalte A markieren.
Spalte A sind fortlaufende Nummern. In Spalte B sind die Lehrgangsnummern. Spalte B ist aber schon farblich nach Lehrgänge markiert. Deswegen möchte ich gerne das für die jeweilige Zeile des Lehrganges Spalte A markiert wird.
Er muss das natürlich mit einer Schleife durchsuchen weil es die Lehrgänge mehrfach gibt aber mit unterschiedlichen Zeiträumen und ich möchte immer alle markiert haben.
Kann mir da jemand helfen?
Danke schon mal.
Sub Finden()
Dim strSUCH As Variant
Dim rngSUCH As Range
Dim lngFind As Long
Dim strAdr1 As String '1. Find Adresse
Dim lngLRow As Long 'LastRow Variable
Dim n As Integer 'gefundene Zellen
'LastRow in Spalte B suchen (von unten)
lngLRow = Cells(Rows.Count, 2).End(xlUp).Row
'Columns(2).Interior.ColorIndex = xlNone'
Range("A6:A1000" & lngLRow).Interior.ColorIndex = xlNone
strSUCH = Application.InputBox("Bitte Eingabe tätigen:")
Set rngSUCH = Range("B3:B" & lngLRow).Find(What:=strSUCH, _
Lookat:=xlWhole, LookIn:=xlValues, MatchCase:=True)
If Not rngSUCH Is Nothing Then
strAdr1 = rngSUCH.Address
Do
rngSUCH.Offset(0, -1).Interior.ColorIndex = 39
Set rngSUCH = Range("B3:B" & lngLRow).FindNext(rngSUCH)
Loop Until strAdr1 = rngSUCH.Address
rngSUCH.Select
Else
MsgBox "Der gesuchte Wert " & strSUCH & " wurde nicht gefunden.", _
64, "Nicht gefunden."
End If
End Sub