AW: For Schleife//Code gepostet
30.03.2004 19:57:45
Sven
Hallo,
ich habe hier mal den Code der sich insgesammt mit der Suche beschäftigt mal als Text reingestellt. Es ist eine Menge, aber vielleicht findet ja jemand was.
Vielen Dank.
Gruß
Sven
Option Explicit
Public Sub Suchen()
Dim Suchtext As Variant
Do
Suchtext = Application.InputBox("Bitte geben Sie einen Suchbegriff ein.", "Suchbegriff Abfrage")
'Der eingegebene Text wird in Kleinbuchstaben umgewandelt
Suchtext = LCase(Suchtext)
'Wenn kein Suchtext eingegeben und 'OK' gewählt wird, wird die Do-Schleife verlassen
If Suchtext = False Then Exit Do
If Trim(Suchtext) "" Then
Call Suche((Suchtext))
Exit Do
End If
Do
Suchtext = Application.InputBox("Sie haben keinen Suchbegriff eingegeben. Bitte
geben Sie einen Suchbegriff ein und wählen Sie 'OK', um die Suche zu starten oder wählen
Sie abbrechen, um die Suche zu beenden!", "Suchbegriff Abfrage")
'Der eingegebene Text wird in Kleinbuchstaben umgewandelt
Suchtext = LCase(Suchtext)
'MsgBox "Bitte geben Sie einen Suchbegriff ein und drücken Sie 'OK', um die Suche zu starten oder drücken Sie 'Abbrechen', um die Suche zu beenden!", 48, "Hinweis"
If Suchtext = False Then Exit Do
'Wenn ein Suchbegriff eingegeben und 'OK' gewählt wird
If Trim(Suchtext) "" Then
Call Suche((Suchtext))
Exit Do
End If
Loop
MsgBox "Suche abgebrochen!00", 48, "Hinweis"
Exit Sub
Loop
End Sub
Private Sub Suche(Suchtext As String)
Dim SuchKatalogblattName As String
Dim objBlatt As Worksheet
Dim objSuchKatalogblatt As Worksheet
Dim objZelle As Range
Dim objZeile As Range
Dim strErsteFundstelle As String
Dim intButton As Integer
'Dim objForm As UserForm
Dim strFundstelle As String
Dim strSuchtext As String
Dim Gefunden As Boolean
Dim Erste As String
strSuchtext = Suchtext
Gefunden = False
If objSuchKatalogblatt Is Nothing Then
'Alle Blätter durchlaufen
For Each objBlatt In ActiveWorkbook.Worksheets
If objBlatt.Name <> "Übersicht" Then
With objBlatt.UsedRange
Set objZelle = .Find(What:=Trim(strSuchtext), LookIn:=xlValues)
If Not objZelle Is Nothing Then
Erste = objZelle.Address
Gefunden = True
'Do
strFundstelle = objBlatt.Name & "!" & objZelle.Address
Call Suchkatalogblattanlegen(strSuchtext, strFundstelle, objBlatt, objZelle)
'Exit Do
Exit Sub
'Set objZelle = .FindNext(objZelle)
'Loop While Not objZelle Is Nothing And objZelle.Address <> Erste
End If
End With
End If
Next objBlatt
'Infobox mit "Keine Fundstellen!" öffnen
If Gefunden = False Then MsgBox "Keine Fundstellen!0000!", vbInformation, APP_NAME
End If
End Sub
Public Sub Suchkatalogblattanlegen(strSuchtext As String, strErsteFundstelle As String, objBlatt As Worksheet, objZelle As Range)
Dim objSuchKatalogblatt As Worksheet
'Prüfen, ob SuchKatalogblatt bereits existiert
Set objSuchKatalogblatt = GetWorksheet(strSuchtext)
'Wenn SuchKatalogblatt nicht existiert, dann...
If objSuchKatalogblatt Is Nothing Then
'Neues Katalogblatt anlegen
Set objSuchKatalogblatt = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'Suchtext bildet Namen des SuchKatalogblattes
objSuchKatalogblatt.Name = strSuchtext
'********************************
'***SuchKatalogblatt gestalten***
'********************************
'SuchKatalogblatt gestalten
With objSuchKatalogblatt
'Spaltenformatierungen festlegen
.Columns(1).ColumnWidth = 10
.Columns(2).ColumnWidth = 26
.Columns(3).ColumnWidth = 24
.Columns(4).ColumnWidth = 7
.Columns(5).ColumnWidth = 24
.Columns(6).ColumnWidth = 26
.Columns("A").NumberFormat = "0000"
.Columns("B").NumberFormat = "0000"
.Columns("C").NumberFormat = "00"
'Zeileninhalte und -formatierungen festlegen
'Alle Zellinhalte links ausrichten
.Rows.HorizontalAlignment = xlLeft
With .Rows(1)
.Cells(1).Value = "CD-Nummer:"
.Cells(1).Font.Size = 8
.Cells(1).Font.Bold = True
End With
With .Rows(1)
.Cells(2).Value = "CD-Seite:"
.Cells(2).Font.Size = 8
.Cells(2).Font.Bold = True
End With
With .Rows(1)
.Cells(3).Value = "Künstler:"
.Cells(3).Font.Size = 8
.Cells(3).Font.Bold = True
End With
With .Rows(1)
.Cells(4).Value = "Album:"
.Cells(4).Font.Size = 8
.Cells(4).Font.Bold = True
End With
End With
End If
MsgBox "Ein Katalogblatt mit folgendem Namen wurde angelegt: " & strSuchtext, vbInformation
Call Suchroutine(strSuchtext, strErsteFundstelle, objBlatt, objZelle, objSuchKatalogblatt)
End Sub
Private Sub Suchroutine(strSuchtext As String, strErsteFundstelle As String,
objBlatt As Worksheet, objZelle As Range, objSuchKatalogblatt As Worksheet)
'Dim objBlatt As Worksheet
'Dim objSuchKatalogblatt As Worksheet
'Dim objZelle As Range
'Dim objZeile As Range
'Dim strErsteFundstelle As String
Dim intButton As Integer
Dim objForm As UserForm
'Verwendeten Bereich jedes Blatts durchsuchen
For Each objBlatt In ActiveWorkbook.Worksheets
With objBlatt.UsedRange
'***Hier kommt man von Suchkatalogblattanlegen aus hin***
Do
'Blatt mit erster Fundstelle aktivieren
objBlatt.Activate
'Fundstelle markieren
objZelle.Select
''End Sub
'Anwender fragen, ob Suche fortgesetzt werden soll
intButton = MsgBox("Weiter suchen?", vbQuestion + vbYesNo, APP_NAME)
'Wenn Antwort nicht 'Ja' (NEIN) lautet, dann...
If intButton vbYes Then
'Fragen, ob das Suchkatalogblatt geöffnet werden soll
intButton = MsgBox("Das Suchkatalogblatt öffnen?22", vbQuestion + vbYesNo, APP_NAME)
'Wenn die Antwort nicht 'Ja' (NEIN) lautet, dann...
If intButton vbYes Then
'Infofenster mit "Suche beendet!" öffnen und...
MsgBox "Suche beendet3!", vbInformation, APP_NAME
'...Makro beenden
Exit Sub
Else
'Suchkatalogblatt aktivieren
objSuchKatalogblatt.Activate
'Makro beenden
Exit Sub
End If
End If
'Nach nächstem Vorkommen suchen
Set objZelle = .FindNext(objZelle)
'Schleife wiederholen solange weitere Fundstellen auftauchen und erste Fundstelle noch nicht erreicht
Loop While Not objZelle Is Nothing And objBlatt.Name & "!" & objZelle.Address strErsteFundstelle
End With
Next
End Sub