If.. like... or.. then...
19.01.2017 16:46:40
John
habe ein kleines Problem..
Ich möchte ein Konto mit ca. 6.000 Buchungen auf bestimmte Begriffe überprüfen lassen und wie folgt farblich kennzeichnen:
grün = Buchung in Ordnung
orange = keine Zuordnung möglich
rot = falsche Buchung
Am Schluss sollen nur noch die roten und die orangenen Zeilen stehen bleiben!
Das unten aufgeführte Makro hängt sich jedoch nach ca. 1.900 geprüften Zeilen immer auf...
Bzw. es stoppt kurz. und markiert dann nicht mehr grün weiter!
Siehe fett markierte Stelle!
Also er markiert bis dahin alles schön fleißig mit grün, wenn einer der Begriffe im Text vorkommt (z.B. Traini, Schul, Reise, Verpfl, ...)
Leider kann ich aus Datenschutz keine Beispieldateien uploaden.
Hat vielleicht trotzdem jmd. eine Idee, was ich falsch mache..?
Vielen Dank!
BG John
Sub Kontrolle()
'J.K. 16.01.2017
Dim n As Long
Dim o As Long
Dim p As Long
Dim k As Long
'Application.ScreenUpdating = False
k = 8
p = 8
'Vorbearbeitung des Datenabzuges
Workbooks("Prüfungs-Tool Konto 1775115000.xls").Sheets("Datenabzug hier einfügen").Activate
Range("A2:A3").Select
Selection.Cut
Range("D2").Select
ActiveSheet.Paste
Columns("A:C").Select
Selection.Delete Shift:=xlToLeft
Range("D2:E3").Select
Selection.Cut
Range("B2").Select
ActiveSheet.Paste
Columns("D:E").Select
Selection.Delete Shift:=xlToLeft
Range("N:N,Q:Q,R:R,S:S").Select
Selection.Delete Shift:=xlToLeft
Columns("A:P").Select
Columns("A:P").EntireColumn.AutoFit
'Alle Zeilen orange färben
Dim loLetzte1 As Long
loLetzte1 = IIf(IsEmpty(Cells(Rows.Count, 1)), _
Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
Range("A8:O" & loLetzte1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
'Bestimmte Zeichenketten grün markieren
Dim loLetzte11 As Long
loLetzte11 = IIf(IsEmpty(Cells(Rows.Count, 1)), _
Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
loLetzte12 = loLetzte11 - 6
Range("O" & k).Select
Do While loLetzte11 > 1
'Begriffe einfügen
If (ActiveCell.Value Like "*Traini*" Or _
ActiveCell.Value Like "*Schul" Or _
ActiveCell.Value Like "*Weiterbild*" Or _
ActiveCell.Value Like "*Reise*" Or _
ActiveCell.Value Like "*Verpfl*" Or _
ActiveCell.Value Like "*Bus*" Or _
ActiveCell.Value Like "*Ausbil*" Or _
ActiveCell.Value Like "*Betreu*" Or _
ActiveCell.Value Like "*Meet*" Or _
ActiveCell.Value Like "*Workshop*" Or _
ActiveCell.Value Like "*Tag*" Or _
ActiveCell.Value Like "*Semi*" Or _
ActiveCell.Value Like "*Lehrgang*" Or _
ActiveCell.Value Like "*Geb*" Or _
ActiveCell.Value Like "*Tagung*" Or _
ActiveCell.Value Like "*ün*" Or _
ActiveCell.Value Like "*Honorar*" Or _
ActiveCell.Value Like "*Sicherheit*" Or _
ActiveCell.Value Like "*Kick*" Or _
ActiveCell.Value Like "*Bosch*" Or _
ActiveCell.Value Like "*Studien*" Or _
ActiveCell.Value Like "*Prüfung*" Or _
ActiveCell.Value Like "*Team*" Or _
ActiveCell.Value Like "*Miete*" Or _
ActiveCell.Value Like "*Übern*") Then
Range("A" & k, ("O" & k)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("O" & k).Select
ActiveCell.Offset(1, 0).Select
k = k + 1
Else
ActiveCell.Offset(1, 0).Select
k = k + 1
End If
loLetzte11 = loLetzte11 - 1
Loop
'Bestimmte Zeichenketten rot markieren
Dim loLetzte7 As Long
loLetzte7 = IIf(IsEmpty(Cells(Rows.Count, 1)), _
Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
loLetzte8 = loLetzte7 - 6
Range("O" & p).Select
Do While loLetzte8 > 1
If (ActiveCell.Value Like "*Betriebsveranst*" Or _
ActiveCell.Value Like "*feier*" Or _
ActiveCell.Value Like "*fest*") Then
Range("A" & p, ("O" & p)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("O" & p).Select
ActiveCell.Offset(1, 0).Select
p = p + 1
Else
ActiveCell.Offset(1, 0).Select
p = p + 1
End If
loLetzte8 = loLetzte8 - 1
Loop
'Zeilen nach Farben sortieren und dann grünen Zeilen ausblenden
Dim r As Range
For Each r In ActiveSheet.UsedRange.Rows
If r.Interior.Color = 5296274 Then r.EntireRow.Hidden = True
Next r
End Sub