AW: da .. Makro bis Ende
fcs
Hallo Mike,
aus der ursprünglichen Frage blicke ich nicht durch, welche Zellen relativ zu den Fundzellen einen Eintrag "X" bekommen sollen.
ImPrinzip kannst du wie folgt eine Suchschleife aufbauen.
Gruß
Franz
Sub Markieren()
'Sucht nach Begriffen in SPalte 6 (F) und setzt eine oder mehrere Markierungen
On Error GoTo Fehler
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
If fncSuchen(vFind:="GEBÜHREN", SuchBereich:=ActiveSheet.Columns(6)) _
= False Then GoTo Fehler
If fncSuchen(vFind:="P R I M", SuchBereich:=ActiveSheet.Columns(6)) _
= False Then GoTo Fehler
If fncSuchen(vFind:="ÜBER- / UN", SuchBereich:=ActiveSheet.Columns(6)) _
= False Then GoTo Fehler
MsgBox "Markierung abgeschlossen", vbInformation + vbOKOnly, "Spezialsuche"
Fehler:
With Err
Select Case .Number
Case 0 'Null Probleme
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
Function fncSuchen(vFind As Variant, SuchBereich As Range, _
Optional vMarker As Variant = "X") As Boolean
Dim sAdresse1, Zelle As Range
On Error GoTo Fehler
fncSuchen = True
Set Zelle = SuchBereich.Find(what:=vFind, LookIn:=xlValues, lookat:=xlPart)
If Zelle Is Nothing Then
MsgBox "Suchbegriff """ & vFind & """ wurde nicht gefunden", _
vbInformation + vbOKOnly, "Spezialsuche"
Else
sAdresse1 = Zelle.Address '1. Fundstelle merken
Do
With Zelle
Select Case vFind
Case "GEBÜHREN"
'Zellen, die relativ zu Zellen mit "GEBÜHREN " markiert werden sollen
.Offset(1, -2).Resize(10).Value = "x"
.Offset(73, -2).Resize(9).Value = "x"
.Offset(86, -2).Value = "x"
.Offset(89, -2).Value = "x"
.Offset(129, -2).Resize(15).Value = "x"
Case "P R I M"
'Zellen, die relativ zu Zellen mit "P R I M" markiert werden sollen
.Offset(-11, -2).Range("A1") = "x"
.Offset(1, 0).Range("A1") = "x"
.Offset(2, 0).Range("A1") = "x"
Case "ÜBER- / UN"
'Zellen, die relativ zu Zellen mit "ÜBER- / UN " markiert werden sollen
.Offset(13, -2).Range("A1") = "x"
.Offset(1, 0).Range("A1") = "x"
Case Else
MsgBox "Für Suchbegriff """ & vFind & _
""" wurde keine Case-Anweisung mit den zu markierenden Zellen erstellt", _
vbInformation + vbOKOnly, "Spezialsuche"
End Select
End With
'Neue Suche
Set Zelle = SuchBereich.FindNext(After:=Zelle)
Loop Until Zelle Is Nothing Or Zelle.Address = sAdresse1
End If
Fehler:
If Err.Number <> 0 Then
fncSuchen = False
MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description, _
vbInformation, "Fehler in fcSuchen"
End If
End Function