Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1016to1020
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Such Makro Erweiterung

Such Makro Erweiterung
20.10.2008 18:37:00
sockel939
Hallo Excelfreunde,
Ich habe folgenden Code:
Sub Suchen_und_anzeigen()
Dim Meldung As Byte, Pos As Byte
Dim Schleife As Byte, y As Byte
Dim Begriff, Suchen() As Variant
Dim Bereich As Range
Dim n%, x%, xZelle%, yZelle%
Dim xTabelle$(), Adresse$(), Text$
' Suchbegriff eingeben
Begriff = InputBox _
("Bitte den zu suchenden Wert eingeben. Sollen 2 Werte" & vbCrLf & _
"gleichzeitig gesucht werden, dann mit Zeichen + " & vbCrLf & _
"voneinander trennen (z.B.: Summe+die)." & vbCrLf & vbCrLf & _
"ENTER ohne Wert = Abbruch", "S U C H M O D U S")
If Begriff = "" Then Exit Sub
Pos = InStr(Begriff, "+")
If Pos Then
ReDim Suchen(2)
Suchen(1) = Left(Begriff, Pos - 1)
Suchen(2) = Right(Begriff, Len(Begriff) - Pos)
Schleife = 2
Else
ReDim Suchen(1)
Suchen(1) = Begriff
Schleife = 1
End If
Application.ScreenUpdating = False
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
x = 1
For y = 1 To Schleife
For n = 1 To Sheets.Count
' Letzte Zelle des Bereiches ermitteln. Diese Zelle wird als Startzelle für
' die Suche deffiniert, da Suche nach dieser Zelle, also in erster Zelle
' des Bereiches beginnt.
'Bereich festlegen
Set Bereich = Worksheets(n).UsedRange
With Worksheets(n).Range(Bereich.Address)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
With Sheets(n).Range(Bereich.Address)
Set c = .Find(Suchen(y), after:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve Adresse(x): ReDim Preserve xTabelle(x)
xTabelle(x) = Sheets(n).Name
Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set c = .FindNext(c)
x = x + 1
Loop While Not c Is Nothing And c.Address ErsteAdresse
End If
End With
Next n
Next y
- Gibt es eine möglichkeit diesen so zu modifizieren das er mir 2 oder mehr begriffe in einer Zeile von A bis O sucht und nicht die letzte Zelle als Bezug nimmt sondern nur Zeile für Zeile von A bis O?
Hab schon viel Hirnschmalz verbraten und komm nicht drauf!
Danke mal im Voraus
Gruß
Tom

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Such Makro Erweiterung
21.10.2008 15:31:00
fcs
Hallo Tom,
hier eine Anpassung, die jede Fundzeile nur einmal im Array sammelt, wenn einer der Suchbegriffe in der Zeile vorkommt.
Hilft dir ggf. ja weiter um zu deinem Ziel zu kommen.
Gruß
Franz

Sub Suchen_und_anzeigen()
Dim Meldung As Byte, Pos As Byte
Dim y&, zeile&
Dim Begriff, Suchen As Variant
Dim Bereich As Range
Dim n&, x&, z&, xZelle&, yZelle&
Dim xTabelle$(), Adresse$(), Text$, ErsteAdresse$
Dim strFundstellen$
Dim c As Range
Dim bolZeileschongefunden As Boolean
' Suchbegriff eingeben
Begriff = InputBox _
("Bitte den zu suchenden Wert eingeben. Sollen mehrere Werte" & vbCrLf & _
"gleichzeitig gesucht werden, dann mit Zeichen + " & vbCrLf & _
"voneinander trennen (z.B.: Summe+die)." & vbCrLf & vbCrLf & _
"ENTER ohne Wert = Abbruch", "S U C H M O D U S")
If Begriff = "" Then Exit Sub
'Eingabe am Plus-Zeichen in Array aufteilen
Suchen = Split(Begriff, "+")
Application.ScreenUpdating = False
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
For n = 1 To Worksheets.Count
For y = LBound(Suchen) To UBound(Suchen)
' Letzte Zelle des Bereiches ermitteln. Diese Zelle wird als Startzelle für
' die Suche deffiniert, da Suche nach dieser Zelle, also in erster Zelle
' des Bereiches beginnt.
'Bereich festlegen
Set Bereich = Worksheets(n).UsedRange
With Bereich
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
With Bereich
Set c = .Find(Suchen(y), after:=Cells(yZelle, xZelle), LookIn:=xlValues)
zeile = 0
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
If zeile  c.Row Then
bolZeileschongefunden = False
'Prüfen ob Zeile schon als Fundstelle erfasst wurde
If x > 0 Then
For z = LBound(Adresse) To UBound(Adresse)
If Adresse(z) = c.Row And xTabelle(z) = Worksheets(n).Name Then
bolZeileschongefunden = True
Exit For
End If
Next
End If
If bolZeileschongefunden = False Then
'Neue Fundstelle in Array aufnehmen
x = x + 1
ReDim Preserve Adresse(1 To x): ReDim Preserve xTabelle(1 To x)
xTabelle(x) = Sheets(n).Name
Adresse(x) = c.Row
'              Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
zeile = c.Row
End If
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address  ErsteAdresse
End If
End With
Next y
Next n
'Fundstellen ausgeben in Meldung
strFundstellen = "Begriff(e): """ & Begriff & """  gefunden in"
If x > 0 Then
For n = LBound(Adresse) To UBound(Adresse)
strFundstellen = strFundstellen & vbLf & xTabelle(n) & ", Zeile:   " & Adresse(n)
Next
Else
strFundstellen = strFundstellen & vbLf & "nichts gefunden"
End If
MsgBox strFundstellen
End Sub


Anzeige
AW: Such Makro Erweiterung
21.10.2008 18:09:00
sockel939
Das ist Perfekt - Danke
Meister seines Faches.
Gruß
Tom

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige