Suchen Zeilenweise!
11.04.2005 14:44:49
markus
ich habe folgendes Problem. Das nachfolgende Programm durchsucht einen Bereich nach der Schriftfarbe Rot und zählt alle Zellen, welche eine Rote Schriftfarbe haben und nicht doppelt sind.
Nun bräuchte ich folgende Änderung. Ich möchte nur die doppelten Zellen in einer Zeile berücksichtigen nicht in dem kompletten Suchbereich.
Soll heißen in der Zeile 50 gibt es zwei Zellen mit roter Schrift die gleich sind z.B. (Hans / rote Schrift). Also soll nur eine 1 gezählt werden. Wenn jetzt aber Hans in der Zeile 50 und 51 steht soll eine 1 für die Zeile 50 und eine 1 für die Zeile 51 gezählt werden. Gibt es eine Möglichkeit diesen VBA Code so zu ändern, dass nur die doppelten Zeilenweise und nicht Bereichsweise kontrolliert werden.
Sub Rote_Finden()
Application.ScreenUpdating = False
'Sheets("Tabelle1").Activate
Dim Anfang As Long
Dim Ende As Long
Anfang = Range("AA2") ' Zeile des Aktuellen Datums
Ende = Range("AC2") ' Datum plus Anzahl Tage in der Zukunft
Sheets("Belegungsplan").Activate
Dim Zelle As Range
Dim rngSuche As Range
Dim colGefunden As New Collection
Dim i As Long, j As Long
Dim anzRote
Dim Doppelt As Boolean
'Set rngSuche = ActiveSheet.Range("E161:K300")
Set rngSuche = ActiveSheet.Range("E" & Anfang & ":K" & Ende)
j = 1
For Each Zelle In rngSuche
If Not IsEmpty(Zelle) And Zelle.Font.ColorIndex = 3 Or Zelle.Font.ColorIndex = 10 Then
Doppelt = False
For i = 1 To colGefunden.Count
If Zelle.Value = colGefunden(i) Then
Doppelt = True
End If
Next i
If Doppelt = False Then
anzRote = anzRote + 1
colGefunden.Add Zelle.Value
End If
End If
If j Mod 7 = 0 Then
'Am Ende jeder Zeile wird die Anzahl roter Zellen in Spalte A
'von Tabelle2 geschrieben
Sheets("Belegungsplan").Cells(Zelle.Row, 27) = anzRote
Sheets("Belegungsplan").Cells(Zelle.Row, 28) = anzRote
anzRote = 0
End If
j = j + 1
Next Zelle
Sheets("Belegungsplan").Activate
Application.ScreenUpdating = True
'MsgBox "Anzahl roter Texte: " & colGefunden.Count
End Sub
Hoffe Ihr habt eine Idee
Danke Euch
Gruß Markus