Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
536to540
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
536to540
536to540
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Such-Makro ?

Such-Makro ?
28.12.2004 09:13:03
Jens
Guten Morgen, ich hoffe ihr könnt mir vielleicht weiter helfen.
Folgende Ausgangslage: Eine Arbeitsmappe mit mehreren Tabellenblättern, die alle gleich aufgebaut sind. Nun möchte ich eine Suchabfrage in einem neuen Tabellenblatt starten, die in Spalte B oder D nach einer bestimmten Buchstaben-/Zeichenkombination (über Eingabefeld jedes mal neu definierbar) sucht und JEDE Zeile in der die Kombination gefunden wurde in ein neues Blatt kopiert. Also quasi eine Art Auswertung über eine Suche. Ich habe da schon selber versucht mit der Makroaufzeichnung etwas zu machen, bin aber zu keiner funktionierenden Lösung gekommen.
Gruß
Jens

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Such-Makro ?
28.12.2004 09:53:11
Josef
Hallo Jens!
Probier mal.

Sub Suchen()
Dim rng As Range
Dim wks As Worksheet, ziel As Worksheet
Dim sFirst As String, sFind As String, sCol As String, sTemp As String
Dim arr As Variant
Dim lRow As Long
Set wks = Sheets("Tabelle1")  'Tabelle in der gesucht wird
Set ziel = Sheets("Auswertung")   'Tabelle für die Ergebnisse
Application.ScreenUpdating = False
On Error GoTo ERRORHANDLER
sTemp = InputBox("Bitte geben sie die zu durchsuchende Spalte" & vbLf & _
"und den Suchbegriff getrennt durch Semikolon (;) ein!" & vbLf & vbLf & _
"Beispiel:  ""C;text""", "Suchen")
If sTemp = "" Then Exit Sub
If InStr(1, sTemp, ";") = 0 Then
sFind = sTemp
sCol = "B"
Else
arr = Split(sTemp, ";")
sCol = UCase(Trim(arr(0)))
sFind = Trim(arr(1))
If sCol = "" Then sCol = "B"
If sFind = "" Then Exit Sub
End If
'Daten in der Zieltabelle löschen
ziel.Cells.ClearContents
lRow = 1
Set rng = wks.Columns(sCol).Find(What:=sFind, LookIn:=xlValues, _
LookAt:=xlPart, after:=Columns(sCol).Cells(65536))
If Not rng Is Nothing Then
sFirst = rng.Address
Do
'Komplette Zeile der Fundstellekopieren
rng.EntireRow.Copy ziel.Cells(lRow, 1)
''Nur die Fundstelle kopieren
'ziel.Cells(lRow, 1) = rng
lRow = lRow + 1
Set rng = wks.Columns(sCol).FindNext(rng)
Loop While rng.Address <> sFirst
End If
Application.ScreenUpdating = True
Exit Sub
ERRORHANDLER:
Application.ScreenUpdating = True
MsgBox "Es ist ein Fehler aufgetreten!"
End Sub

Gruß Sepp
Anzeige
AW: Such-Makro ?
28.12.2004 11:06:22
Jens
Danke dir für die Hilfe, es funktioniert so weit schon mal. Wäre es möglich die Suche nicht nur auf eine Tabelle zu beschränken sondern auf die ganze Mappe ? Also das alle Tabellen dursucht werden ? ODer zuminest so, das alle Tabellen durchsucht werden, die in Frage kommen.
Besipiel:
Set wks = Sheets("Tabelle1") 'Tabelle in der gesucht wird -- Das war ja von dir, wie muß ich das erweitern, das mehrere Tabellen durchsucht werden ?
AW: Such-Makro ?
28.12.2004 12:21:38
Josef
Hallo Jens!
Danach hast du nicht gefragt!
Aber kein Problem:

Sub Suchen()
Dim rng As Range
Dim wks As Worksheet, ziel As Worksheet
Dim sFirst As String, sFind As String, sCol As String, sTemp As String
Dim arr As Variant
Dim lRow As Long
Set ziel = Sheets("Auswertung")   'Tabelle für die Ergebnisse
Application.ScreenUpdating = False
On Error GoTo ERRORHANDLER
sTemp = InputBox("Bitte geben sie die zu durchsuchende Spalte" & vbLf & _
"und den Suchbegriff getrennt durch Semikolon (;) ein!" & vbLf & vbLf & _
"Beispiel:  ""C;text""", "Suchen")
If sTemp = "" Then Exit Sub
If InStr(1, sTemp, ";") = 0 Then
sFind = sTemp
sCol = "B"
Else
arr = Split(sTemp, ";")
sCol = UCase(Trim(arr(0)))
sFind = Trim(arr(1))
If sCol = "" Then sCol = "B"
If sFind = "" Then Exit Sub
End If
'Daten in der Zieltabelle löschen
ziel.Cells.ClearContents
lRow = 1
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> ziel.Name Then 'Schleife über alle Tabellen
''oder - um auch andere Tabellen auszuschliessen
'If wks.Name <> ziel.Name And wks.Name <> "andereTabelle" Then
Set rng = wks.Columns(sCol).Find(What:=sFind, LookIn:=xlValues, _
LookAt:=xlPart, after:=Columns(sCol).Cells(65536))
If Not rng Is Nothing Then
sFirst = rng.Address
Do
'Komplette Zeile der Fundstellekopieren
rng.EntireRow.Copy ziel.Cells(lRow, 1)
''Nur die Fundstelle kopieren
'ziel.Cells(lRow, 1) = rng
lRow = lRow + 1
Set rng = wks.Columns(sCol).FindNext(rng)
Loop While rng.Address <> sFirst
End If
Next
Application.ScreenUpdating = True
Exit Sub
ERRORHANDLER:
Application.ScreenUpdating = True
MsgBox "Es ist ein Fehler aufgetreten!"
End Sub

Gruß Sepp
Anzeige
AW: Ein "End If" Fehlt!
28.12.2004 12:23:58
Josef
Hallo Jens!
So stimmt's:

Option Explicit
Sub Suchen()
Dim rng As Range
Dim wks As Worksheet, ziel As Worksheet
Dim sFirst As String, sFind As String, sCol As String, sTemp As String
Dim arr As Variant
Dim lRow As Long
Set ziel = Sheets("Auswertung")   'Tabelle für die Ergebnisse
Application.ScreenUpdating = False
On Error GoTo ERRORHANDLER
sTemp = InputBox("Bitte geben sie die zu durchsuchende Spalte" & vbLf & _
"und den Suchbegriff getrennt durch Semikolon (;) ein!" & vbLf & vbLf & _
"Beispiel:  ""C;text""", "Suchen")
If sTemp = "" Then Exit Sub
If InStr(1, sTemp, ";") = 0 Then
sFind = sTemp
sCol = "B"
Else
arr = Split(sTemp, ";")
sCol = UCase(Trim(arr(0)))
sFind = Trim(arr(1))
If sCol = "" Then sCol = "B"
If sFind = "" Then Exit Sub
End If
'Daten in der Zieltabelle löschen
ziel.Cells.ClearContents
lRow = 1
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> ziel.Name Then 'Schleife über alle Tabellen
''oder - um auch andere Tabellen auszuschliessen
'If wks.Name <> ziel.Name And wks.Name <> "andereTabelle" Then
Set rng = wks.Columns(sCol).Find(What:=sFind, LookIn:=xlValues, _
LookAt:=xlPart, after:=Columns(sCol).Cells(65536))
If Not rng Is Nothing Then
sFirst = rng.Address
Do
'Komplette Zeile der Fundstellekopieren
rng.EntireRow.Copy ziel.Cells(lRow, 1)
''Nur die Fundstelle kopieren
'ziel.Cells(lRow, 1) = rng
lRow = lRow + 1
Set rng = wks.Columns(sCol).FindNext(rng)
Loop While rng.Address <> sFirst
End If
End If
Next
Application.ScreenUpdating = True
Exit Sub
ERRORHANDLER:
Application.ScreenUpdating = True
MsgBox "Es ist ein Fehler aufgetreten!"
End Sub

Gruß Sepp
Anzeige
AW: Ein "End If" Fehlt!
28.12.2004 13:00:51
Jens
Supi *freu*
Vielen Dank, das erspart mir eine ganze Menge Arbeit und sorry falls ich mich am Anfang falsch ausgedrückt habe.
Gruß
Jens

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige