Hallo
Lösche alle bisherigen Code und kopiere diese in ein Modul
Option Explicit
'Initialisieren zum Spielen von Sounds
Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'Globale Variablen für den Suchbereich
'damit die Farben bei Bedarf wieder zurückgesetzt werden können
'Beginne mit der Suche in Zeile 1
Const startR As Long = 1
'Ende des Suchbereiches wird dynamisch bestimmt
Public lastRow As Long
'Haben beide Variablen den gleichen Wert
'ist die Suche auf diese eine Spalte begrenzt
''..oder bei 3 wird der Suchbegriff auf Spalte C erweitert
'Die zweite Zahl muss auf jeden Fall höher sein
Const col1 As Integer = 2 'Spalte B
Const col2 As Integer = 2 'Spalte B
'Die WAV-Datei die dann abgespielt werden soll
Const mySoundFile As String = "c:\windows\media\tada.wav"
Sub Suchbegriff_markieren()
'by Ramses
'Sucht in einem bestimmten Bereich nach einem Begriff
'und schreibt einen bestimmten Wert in eine definierte Offset Spalte
'Allgemeine Variablen
Dim tarWks As Worksheet, i As Integer, FarbMarker As Integer
Dim chkFarbe As Variant, Qe As Integer
Dim rng As Range, sAddress As String, strDelim As String
'Suchbegriff
Dim sFind As String, sFindArr As Variant 'Wird bei Bedarf auch als Array verwendet
'Sonstige Variablen für den Code
Dim tmpCounter As Integer
'*******************************************
'Hier die Anpassungen für die individuellen
'Einstellungen vornehmen
'Trennzeichen anhand dessen mehrere Suchbegriffe
'bei der Eingabe definiert werdn können
strDelim = " " 'EIN Leerzeichen !!!
'Mit welcher Farbe sollen die Zellen markiert werden
'Farbe: 1 = schwarz, 2 = weiss, 3 = rot,
'4 = hellgrün, 5 = blau, 6 = gelb
'7 = Pink, 8 = hellbau, 9 = Schwarz
FarbMarker = 3
'*********************************************
'Ab hier nichts mehr ändern
'Suchbegriff definieren
If col2 < col1 Then
MsgBox "Der Suchbereich ist negativ definiert", vbCritical + vbOKOnly, "Fehler"
Exit Sub
End If
Set tarWks = ActiveSheet
sFind = InputBox("Bitte Suchbegriff eingeben:")
If sFind = "" Then Exit Sub
sFindArr = Split(sFind, strDelim)
'On Error Resume Next
chkFarbe = InputBox("In welcher Farbe sollen der/die Suchbegriff(e):" & vbCrLf & vbCrLf & """" & sFind & """" & vbCrLf & vbCrLf & "markiert werden ?" & vbCrLf & _
"1 = schwarz, 2 = weiss, 3 = rot" & vbCrLf & "4 = hellgrün, 5 = blau, 6 = gelb" & vbCrLf & "7 = Pink, 8 = hellbau, 9 = Schwarz", _
"Farbe für Markierung bestimmen", "3")
If IsNumeric(chkFarbe) Then
If Int(chkFarbe) > 0 And Int(chkFarbe) < 10 Then
If InStr(1, chkFarbe, ".") > 0 Then
MsgBox "Ihre Eingabe: """ & chkFarbe & """ wird auf den Wert: """ & Int(chkFarbe) & """ gerundet.", vbInformation + vbOKOnly, "Info"
End If
FarbMarker = Int(chkFarbe)
End If
Else
MsgBox "Die Farbe: " & chkFarbe & " kann nicht bestimmt werden oder ausserhalb des Bereiches", vbCritical + vbOKOnly, "Fehler"
Exit Sub
End If
On Error GoTo 0
tmpCounter = 0
With tarWks
lastRow = .Cells(Rows.Count, col1).End(xlUp).Row
'Eventuell vorhandes SuchArray abfragen
If UBound(sFindArr) = 0 Then
'Teilbegriff suchen
Set rng = .Range(.Cells(startR, col1), .Cells(lastRow, col2)).Find(What:=sFind, _
LookAt:=xlPart, LookIn:=xlValues)
'Genaue Übereinstimmung suchen
'Set rng = .Range(.Cells(startR, col1), .Cells(lastRow, col2)).Find(What:=sFind, _
LookAt:=xlWhole, LookIn:=xlValues)
'Wert in Formeln suchen
'Set rng = .Range(.Cells(startR, col1), .Cells(lastRow, col2)).Find(What:=sFind, _
LookAt:=xlPart, LookIn:=xlFormulas)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
'zelle wird rot markiert
rng.Interior.ColorIndex = FarbMarker
'Vorkommen zählen
tmpCounter = tmpCounter + 1
'Nächsten Eintrag suchen
Set rng = .Range(.Cells(startR, col1), .Cells(lastRow, col2)).FindNext(after:=rng)
If rng.Address = sAddress Then Exit Do
Loop
End If
ElseIf UBound(sFindArr) > 0 Then
For i = 0 To UBound(sFindArr)
'Alle Begriffe als Teilbegriffe suchen
Set rng = .Range(.Cells(startR, col1), .Cells(lastRow, col2)).Find(What:=sFindArr(i), _
LookAt:=xlPart, LookIn:=xlValues)
'Genaue Übereinstimmung suchen
'Set rng = .Range(.Cells(startR, col1), .Cells(lastRow, col2)).Find(What:=sFindarr(i), _
LookAt:=xlWhole, LookIn:=xlValues)
'Wert in Formeln suchen
'Set rng = .Range(.Cells(startR, col1), .Cells(lastRow, col2)).Find(What:=sFindarr(i), _
LookAt:=xlPart, LookIn:=xlFormulas)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
'zelle wird rot markiert
rng.Interior.ColorIndex = FarbMarker
'Vorkommen zählen
tmpCounter = tmpCounter + 1
'Nächsten Eintrag suchen
Set rng = .Range(.Cells(startR, col1), .Cells(lastRow, col2)).FindNext(after:=rng)
If rng.Address = sAddress Then Exit Do
Loop
End If
Next i
End If
NextStart:
End With
PlayMySound
'Das Windows-Systemereignis für eine Messagebox lässt sich
'damit aber nicht abschalten/abfangen sondern nur überspielen
'Wenn du das haben möchtest, musst du statt der MsgBox eine
'eigene Userform mit der entsprechenden Information
'zur Anzeige bringen
MsgBox prompt:="Keine neue Fundstelle!" & vbCrLf & "Gefunden: " & tmpCounter
Qe = MsgBox("Sollen die Farben wieder zurückgesetzt werden ?", vbQuestion + vbOKCancel + vbDefaultButton2, "Farbenzustand")
If Qe = 1 Then Reset_Colour_Cells
'Falls die Funktion "Get_Colour" verwendet wird
'muss das Sheet neu berechnet werden
'weil eine Farbänderung kein Berechnungsereignis auslöst
ActiveSheet.Calculate
End Sub
Sub PlayMySound()
Dim intCounter As Integer
Application.EnableCancelKey = xlErrorHandler
Call sndPlaySound32(mySoundFile, 1)
End Sub
Sub Reset_Colour_Cells()
If lastRow = 0 Then
'Sollte das erste Finden Makro noch nicht gestartet
'worden sein
lastRow = ActiveSheet.Cells(Rows.Count, col1).End(xlUp).Row
Range(Cells(startR, col1), Cells(lastRow, col2)).Interior.ColorIndex = xlNone
Else
Range(Cells(startR, col1), Cells(lastRow, col2)).Interior.ColorIndex = xlNone
End If
ActiveSheet.Calculate
End Sub
Function Get_Colour(myRng As Range) As Integer
Get_Colour = myRng.Interior.ColorIndex
End Function
In der Tabelle kannst du nun so sortieren.
Das geht aber nur mit einer Hilfsspalte
Sheet1
| | B | C |
| 1 | Das ist | 3 |
| 2 | ist | 3 |
| 3 | Das ist | 3 |
| 4 | Das | -4142 |
| Formeln der Tabelle |
| Zelle | Formel | | C1 | =get_colour(B1) | | C2 | =get_colour(B2) | | C3 | =get_colour(B3) | | C4 | =get_colour(B4) |
|
Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Gruss Rainer