Supportnet / Forum / Tabellenkalkulation
suche funktion über eine Makroprogramm
Frage
Ich würde gerne eine Suchfunktion über ein makro programmieren so das mir das Ergebniss eventuell in enem eigenem bericht aufgelistet wird. Fürs erste würde ich aber schon eine Suchefunkt über ein Makro erstellen können.
Habe leider überhaupt kein Plan... ... Hilfe
Antwort 1 von Guenter
Hallo,
hast Du schon mal versucht über die Makroaufzeichnung weiter zu kommen?
Also Makroaufzeichnung einschalten und dann die Suche manuell ausführen, Makroaufzeichnung abschalten.
Dann hast du in der Entwicklungsumgebung das fertige Makro.
Gruß
Günter
hast Du schon mal versucht über die Makroaufzeichnung weiter zu kommen?
Also Makroaufzeichnung einschalten und dann die Suche manuell ausführen, Makroaufzeichnung abschalten.
Dann hast du in der Entwicklungsumgebung das fertige Makro.
Gruß
Günter
Antwort 2 von rekom
Hallo Günter,
ja das habe ich versucht läuft aber nicht. Meine Vorstellung sollte dann ein fenster aufgehen in dem ich den Suchbegriff schreiben kann und dann bestätige....
Aber trotzdem vielen Dank
ja das habe ich versucht läuft aber nicht. Meine Vorstellung sollte dann ein fenster aufgehen in dem ich den Suchbegriff schreiben kann und dann bestätige....
Aber trotzdem vielen Dank
Antwort 3 von Annan
Hallo rekom,
gebe folgenden Code in ein Klassenmodul u. weise ihn einem CommandButton zu:
Sub Suchbegriff()
´Sucht in der gesamten Mappe nach einem Begriff und kopiert die
´gefundene Zeile in eine Ergebnistabelle
Dim sResultName As String
Dim sWks As Worksheet, tarWks As Worksheet
Dim sRng As Range
Dim sAddress As String
Dim Qe As Integer, i As Integer
Dim fString As Integer, fUnit As Integer
´Suchbegriff
Dim sFind As Variant
Dim cr As Long
fString = 0
fUnit = 0
´Name_der_Zieltabelle
´Bitte Anpassen !!!!
sResultName = "Suchergebnis"
For i = 1 To Worksheets.Count
If Worksheets(i).Name = sResultName Then
Qe = MsgBox("Ergebnistabelle existiert schon!" & vbCrLf & _
"Tabelle löschen ?", vbCritical + vbYesNo, "Wie weiter ... ?")
If Qe = vbNo Then
MsgBox "Makro wird abgebrochen"
Exit Sub
End If
Application.DisplayAlerts = False
Worksheets(i).Delete
Application.DisplayAlerts = True
Exit For
End If
Next i
sFind = InputBox("Bitte Suchbegriff eingeben:", "Suche nach", "Hier Begriff eingeben !")
If sFind = "" Or sFind = "Hier Begriff eingeben !" Then
Qe = MsgBox("Kein Suchbegriff angegeben", vbInformation + vbOKOnly, "Abbruch")
Exit Sub
End If
Worksheets.Add.Name = sResultName
Set tarWks = Worksheets(sResultName)
With tarWks
.Range("A1") = "eingegebenes Suchkriterium:"
.Range("B1") = sFind
.Range("A3") = "In welchen Tabellen gefunden:"
End With
cr = 4
For Each sWks In Worksheets
If sWks.Name <> tarWks.Name Then
Set sRng = sWks.Cells.Find(What:=sFind, _
LookAt:=xlPart, LookIn:=xlFormulas)
If Not sRng Is Nothing Then
sAddress = sRng.Address
Do
Application.GoTo sRng, True
tarWks.Cells(cr, 1) = sWks.Name
tarWks.Cells(cr, 2) = sRng.Offset(0, 1).Value
cr = cr + 1
fString = fString + 1
fUnit = fUnit + sRng.Offset(0, 1).Value
Set sRng = sWks.Cells.FindNext(after:=ActiveCell)
If sRng.Address = sAddress Then Exit Do
Loop
End If
End If
NextStart:
Next sWks
Qe = MsgBox("Suchbegriff: " & sFind & " wurde " & fString & " mal gefunden.", vbInformation + vbOKOnly, "Suche abgeschlossen")
Sheets("Tabelle1").Select
Sheets("Tabelle1").Range("A1").Select
Sheets("Tabelle2").Select
Sheets("Tabelle2").Range("A1").Select
Sheets("Tabelle3").Select
Sheets("Tabelle3").Range("A1").Select
Sheets("Suchergebnis").Select
End Sub
Ich habe 3 Tabellenblätter in meiner Testmappe !
Die Tabellenblätter habe ich mit Tabelle1,Tabelle2,Tabelle3 bezeichnet ! Bei Bedarf musst du diese entsprechend im Code umschreiben.
Ansonsten ist die Funktion, nachdem du den Code einer Schaltfläche zugewiesen hast, selbsterklärend !
MfG
Annan
gebe folgenden Code in ein Klassenmodul u. weise ihn einem CommandButton zu:
Sub Suchbegriff()
´Sucht in der gesamten Mappe nach einem Begriff und kopiert die
´gefundene Zeile in eine Ergebnistabelle
Dim sResultName As String
Dim sWks As Worksheet, tarWks As Worksheet
Dim sRng As Range
Dim sAddress As String
Dim Qe As Integer, i As Integer
Dim fString As Integer, fUnit As Integer
´Suchbegriff
Dim sFind As Variant
Dim cr As Long
fString = 0
fUnit = 0
´Name_der_Zieltabelle
´Bitte Anpassen !!!!
sResultName = "Suchergebnis"
For i = 1 To Worksheets.Count
If Worksheets(i).Name = sResultName Then
Qe = MsgBox("Ergebnistabelle existiert schon!" & vbCrLf & _
"Tabelle löschen ?", vbCritical + vbYesNo, "Wie weiter ... ?")
If Qe = vbNo Then
MsgBox "Makro wird abgebrochen"
Exit Sub
End If
Application.DisplayAlerts = False
Worksheets(i).Delete
Application.DisplayAlerts = True
Exit For
End If
Next i
sFind = InputBox("Bitte Suchbegriff eingeben:", "Suche nach", "Hier Begriff eingeben !")
If sFind = "" Or sFind = "Hier Begriff eingeben !" Then
Qe = MsgBox("Kein Suchbegriff angegeben", vbInformation + vbOKOnly, "Abbruch")
Exit Sub
End If
Worksheets.Add.Name = sResultName
Set tarWks = Worksheets(sResultName)
With tarWks
.Range("A1") = "eingegebenes Suchkriterium:"
.Range("B1") = sFind
.Range("A3") = "In welchen Tabellen gefunden:"
End With
cr = 4
For Each sWks In Worksheets
If sWks.Name <> tarWks.Name Then
Set sRng = sWks.Cells.Find(What:=sFind, _
LookAt:=xlPart, LookIn:=xlFormulas)
If Not sRng Is Nothing Then
sAddress = sRng.Address
Do
Application.GoTo sRng, True
tarWks.Cells(cr, 1) = sWks.Name
tarWks.Cells(cr, 2) = sRng.Offset(0, 1).Value
cr = cr + 1
fString = fString + 1
fUnit = fUnit + sRng.Offset(0, 1).Value
Set sRng = sWks.Cells.FindNext(after:=ActiveCell)
If sRng.Address = sAddress Then Exit Do
Loop
End If
End If
NextStart:
Next sWks
Qe = MsgBox("Suchbegriff: " & sFind & " wurde " & fString & " mal gefunden.", vbInformation + vbOKOnly, "Suche abgeschlossen")
Sheets("Tabelle1").Select
Sheets("Tabelle1").Range("A1").Select
Sheets("Tabelle2").Select
Sheets("Tabelle2").Range("A1").Select
Sheets("Tabelle3").Select
Sheets("Tabelle3").Range("A1").Select
Sheets("Suchergebnis").Select
End Sub
Ich habe 3 Tabellenblätter in meiner Testmappe !
Die Tabellenblätter habe ich mit Tabelle1,Tabelle2,Tabelle3 bezeichnet ! Bei Bedarf musst du diese entsprechend im Code umschreiben.
Ansonsten ist die Funktion, nachdem du den Code einer Schaltfläche zugewiesen hast, selbsterklärend !
MfG
Annan
Antwort 4 von coros
Moin an alle,
da habe ich auch noch eine Variante, so wie ich sie in einigen meiner Exceldateien einsetze. Allerdings verwende ich das Makro ohne die Funktion, dass die gefundenen Begriffe in einem neuen Blatt aufgefürt werden. Das Makro habe ich aber dahingehend abgeändert. Kopiere nachfolgendes Makro in ein StandardModul.
Bei dem Makro wird zum Anfang ein Eingabefenster geöffnet, in dem mindestens die ersten drei Buchstaben des Suchbegriffes eingegeben werden müssen. Danach werden die gefundenen Einträge angesprungen, damit man den Begriff optisch sehen kann. Außerdem wird die komplette Zeile des Suchbegriffes dann in ein separates Tabellenblatt, welches automatisch erstellt wird, kopiert. Wenn Du nicht möchtest, dass die komplette Zeile kopiert wird, dann musst Du in dem Makro die Zeilen
ZeileTab1 = Sheets(Altes_Blatt).Range(gefunden(Index2)).Row
Rows(ZeileTab1).Copy Sheets(Neues_Blatt).Cells(ZeileTab2, 1)
löschen und durch die Zeile
Range(gefunden(Index2)).Copy Sheets(Neues_Blatt).Cells(ZeileTab2, 1)
ersetzen.
Ich hoffe, Du kommst klar. Bei Fragen melde Dich wieder.
MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
da habe ich auch noch eine Variante, so wie ich sie in einigen meiner Exceldateien einsetze. Allerdings verwende ich das Makro ohne die Funktion, dass die gefundenen Begriffe in einem neuen Blatt aufgefürt werden. Das Makro habe ich aber dahingehend abgeändert. Kopiere nachfolgendes Makro in ein StandardModul.
Sub Suchen()
Dim Suchebegriff As String, Bereich As Range, ErsteAddresse As String, _
gefunden() As String, Index1 As Integer, Index2 As Integer, Text As String
Text = "Die nächste Übereinstimmung anzeigen?"
Do
Suchebegriff = InputBox("Mindestens die 3 ersten Buchstaben des" & _
" kompletten Suchbegriff eingeben. Groß-/Kleinschreibung ist egal.", "Suchen")
If Suchebegriff = "" Or Len(Suchebegriff) = 0 Then Exit Sub
Loop Until Len(Suchebegriff) > 2
Set Bereich = Range("A1:IV65536").Find(what:=Suchebegriff, lookat:=xlPart, _
LookIn:=xlValues, MatchCase:=False)
If Bereich Is Nothing Then
Beep
MsgBox "Suchbegriff wurde nicht gefunden! Es ist aber nicht 100% sicher, " & _
"dass der gesuchte Begriff sich nicht in der Tabelle befindet. Überprüfen " & _
"Sie daher bitte nochmal die Schreibweise und geben den Suchbegriff erneut " & _
"ein, oder suchen Sie den Begriff manuell in der Tabelle."
Else
Application.ScreenUpdating = False
Altes_Blatt = ActiveSheet.Name
Worksheets.Add
Neues_Blatt = ActiveSheet.Name
Sheets(Altes_Blatt).Activate
Application.ScreenUpdating = True
ErsteAddresse = Bereich.Address
Do
Index1 = Index1 + 1
ReDim Preserve gefunden(1 To Index1)
gefunden(Index1) = Bereich.Address
Set Bereich = Range("A1:IV65536").FindNext(Bereich)
Loop While Not Bereich Is Nothing And Bereich.Address <> ErsteAddresse
Do
Index2 = Index2 + 1
If Index2 = Index1 Then
Text = ""
End If
ZeileTab2 = Sheets(Neues_Blatt).Range("A65536").End(xlUp).Offset(1, 0).Row
ZeileTab1 = Sheets(Altes_Blatt).Range(gefunden(Index2)).Row
Rows(ZeileTab1).Copy Sheets(Neues_Blatt).Cells(ZeileTab2, 1)
Range(gefunden(Index2)).Select
ActiveWindow.ScrollRow = Selection.Row
ActiveWindow.ScrollColumn = Selection.Column
If MsgBox(CStr(Index2) & ". von " & CStr(Index1) & " gefundenen " & _
"Übereinstimmungen des Suchbegriffes." & vbNewLine & Text, schalter, _
"Anzeige") = 7 Then Exit Do
If Index2 = Index1 Then Exit Do
Loop
Sheets(Neues_Blatt).Activate
End If
End Sub
Bei dem Makro wird zum Anfang ein Eingabefenster geöffnet, in dem mindestens die ersten drei Buchstaben des Suchbegriffes eingegeben werden müssen. Danach werden die gefundenen Einträge angesprungen, damit man den Begriff optisch sehen kann. Außerdem wird die komplette Zeile des Suchbegriffes dann in ein separates Tabellenblatt, welches automatisch erstellt wird, kopiert. Wenn Du nicht möchtest, dass die komplette Zeile kopiert wird, dann musst Du in dem Makro die Zeilen
ZeileTab1 = Sheets(Altes_Blatt).Range(gefunden(Index2)).Row
Rows(ZeileTab1).Copy Sheets(Neues_Blatt).Cells(ZeileTab2, 1)
löschen und durch die Zeile
Range(gefunden(Index2)).Copy Sheets(Neues_Blatt).Cells(ZeileTab2, 1)
ersetzen.
Ich hoffe, Du kommst klar. Bei Fragen melde Dich wieder.
MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
Antwort 5 von rekom
Vielen Dank für Eure Mühe,
werde beide Versionen am Wochende testen.
aber wirklich vielen Dank schon in voraus...
werde beide Versionen am Wochende testen.
aber wirklich vielen Dank schon in voraus...
Antwort 6 von Boerrt
Hallo Jungs,
Ich benötige genau diese Suchfunktion die coros gepostet hat, nur mit dem Unterschied, dass ich einfach nur an die Stelle springen möchte, wo der gesuchte Wert ist (also kein neues Sheet mit den Ergebnissen) und dass ich alle (sind ca. 5 Tabellenblätter) Tabellenblätter durchsuchen möchte. Komme hier einfach nicht weiter, bin aber leider auch noch VBA Anfänger. Ich habe es auch schon mit Dim wsTabelle as Worksheet , For Each wsTabelle In ThisWorkbook.Sheets und Next wsTabelle versucht, doch das klappt alles irgendwie nicht richtig. Könnt ihr mir weiterhelfen?
Hier mal die Sachen, die ich probiert habe und die nicht funktioniert haben:
Sub Suchen()
Dim Suchebegriff As String, Bereich As Range, ErsteAddresse As String, _
gefunden() As String, Index1 As Integer, Index2 As Integer, Text As String
Dim wsTabelle As Worksheet
Text = "Die nächste Übereinstimmung anzeigen?"
Do
Suchebegriff = InputBox("Mindestens die 3 ersten Buchstaben des" & _
" kompletten Suchbegriff eingeben. Groß-/Kleinschreibung ist egal.", "Suchen")
If Suchebegriff = "" Or Len(Suchebegriff) = 0 Then Exit Sub
Loop Until Len(Suchebegriff) > 2
For Each wsTabelle In ThisWorkbook.Sheets
Set Bereich = Range("A1:IV65536").Find(what:=Suchebegriff, lookat:=xlPart, _
LookIn:=xlValues, MatchCase:=False)
If Bereich Is Nothing Then
Beep
MsgBox "Suchbegriff wurde nicht gefunden74"
GoTo Ende
Else
Application.ScreenUpdating = True
ErsteAddresse = Bereich.Address
´Do
´Index1 = Index1 + 1
´ReDim Preserve gefunden(1 To Index1)
gefunden(Index1) = Bereich.Address
End If
Ende:
Next wsTabelle
´Set Bereich = Range("A1:IV65536").FindNext(Bereich)
´If Bereich Is Nothing Then GoTo Ende
´Loop While Bereich.Address <> ErsteAddresse
´Do
´Index2 = Index2 + 1
´If Index2 = Index1 Then
´Text = ""
´End If
Range(gefunden(Index2)).Select
ActiveWindow.ScrollRow = Selection.Row
ActiveWindow.ScrollColumn = Selection.Column
´If MsgBox(CStr(Index2) & ". von " & CStr(Index1) & " gefundenen " & _
´"Übereinstimmungen des Suchbegriffes." & vbNewLine & Text, schalter, _
´"Anzeige") = 7 Then Exit Do
´If Index2 = Index1 Then Exit Do
´Loop
´End If
End Sub
----------------------------------------------
Das hier ist der zweite Code, den ich ausprobiert habe:
Dieser einfache Code macht eigentlich schon das nötigste, was ich brauche, er funktioniert aber nur in meinem gerade aktiven Tabellenblatt. Natürlich wäre so eine Auflistung, die mir aufzählt wieviele Ergebnisse gefunden wurden auch ganz schön.
Option Explicit
Private Sub Suchen7474()
Dim wsTabelle As Worksheet
Dim strSuchBegriff As String
Dim rngSuchErgebnis As Range
strSuchBegriff = InputBox("Bitte Suchbegriff eingeben:", "Alle geöffneten Exceldateien durchsuchen")
If strSuchBegriff = "" Then Exit Sub
For Each wsTabelle In ThisWorkbook.Sheets
Set rngSuchErgebnis = wsTabelle.Cells.Find(strSuchBegriff)
If Not rngSuchErgebnis Is Nothing Then
If rngSuchErgebnis.Select = "" Then
´ Hier bekomme ich den Fehler Die Select Eigenschaft des Range Objekts kann nicht zugeordnet
´werden, wenn ich in einem anderen Tabellenblatt als dem aktiven, in dem ich mich gerade befinde einen Wert suche
Exit Sub
Else
rngSuchErgebnis.Select
End If
End If
Next
End Sub
Wo liegt mein Problem? Was kann man machen?
Gruß, und Danke für die Hilfe
Ich benötige genau diese Suchfunktion die coros gepostet hat, nur mit dem Unterschied, dass ich einfach nur an die Stelle springen möchte, wo der gesuchte Wert ist (also kein neues Sheet mit den Ergebnissen) und dass ich alle (sind ca. 5 Tabellenblätter) Tabellenblätter durchsuchen möchte. Komme hier einfach nicht weiter, bin aber leider auch noch VBA Anfänger. Ich habe es auch schon mit Dim wsTabelle as Worksheet , For Each wsTabelle In ThisWorkbook.Sheets und Next wsTabelle versucht, doch das klappt alles irgendwie nicht richtig. Könnt ihr mir weiterhelfen?
Hier mal die Sachen, die ich probiert habe und die nicht funktioniert haben:
Sub Suchen()
Dim Suchebegriff As String, Bereich As Range, ErsteAddresse As String, _
gefunden() As String, Index1 As Integer, Index2 As Integer, Text As String
Dim wsTabelle As Worksheet
Text = "Die nächste Übereinstimmung anzeigen?"
Do
Suchebegriff = InputBox("Mindestens die 3 ersten Buchstaben des" & _
" kompletten Suchbegriff eingeben. Groß-/Kleinschreibung ist egal.", "Suchen")
If Suchebegriff = "" Or Len(Suchebegriff) = 0 Then Exit Sub
Loop Until Len(Suchebegriff) > 2
For Each wsTabelle In ThisWorkbook.Sheets
Set Bereich = Range("A1:IV65536").Find(what:=Suchebegriff, lookat:=xlPart, _
LookIn:=xlValues, MatchCase:=False)
If Bereich Is Nothing Then
Beep
MsgBox "Suchbegriff wurde nicht gefunden74"
GoTo Ende
Else
Application.ScreenUpdating = True
ErsteAddresse = Bereich.Address
´Do
´Index1 = Index1 + 1
´ReDim Preserve gefunden(1 To Index1)
gefunden(Index1) = Bereich.Address
End If
Ende:
Next wsTabelle
´Set Bereich = Range("A1:IV65536").FindNext(Bereich)
´If Bereich Is Nothing Then GoTo Ende
´Loop While Bereich.Address <> ErsteAddresse
´Do
´Index2 = Index2 + 1
´If Index2 = Index1 Then
´Text = ""
´End If
Range(gefunden(Index2)).Select
ActiveWindow.ScrollRow = Selection.Row
ActiveWindow.ScrollColumn = Selection.Column
´If MsgBox(CStr(Index2) & ". von " & CStr(Index1) & " gefundenen " & _
´"Übereinstimmungen des Suchbegriffes." & vbNewLine & Text, schalter, _
´"Anzeige") = 7 Then Exit Do
´If Index2 = Index1 Then Exit Do
´Loop
´End If
End Sub
----------------------------------------------
Das hier ist der zweite Code, den ich ausprobiert habe:
Dieser einfache Code macht eigentlich schon das nötigste, was ich brauche, er funktioniert aber nur in meinem gerade aktiven Tabellenblatt. Natürlich wäre so eine Auflistung, die mir aufzählt wieviele Ergebnisse gefunden wurden auch ganz schön.
Option Explicit
Private Sub Suchen7474()
Dim wsTabelle As Worksheet
Dim strSuchBegriff As String
Dim rngSuchErgebnis As Range
strSuchBegriff = InputBox("Bitte Suchbegriff eingeben:", "Alle geöffneten Exceldateien durchsuchen")
If strSuchBegriff = "" Then Exit Sub
For Each wsTabelle In ThisWorkbook.Sheets
Set rngSuchErgebnis = wsTabelle.Cells.Find(strSuchBegriff)
If Not rngSuchErgebnis Is Nothing Then
If rngSuchErgebnis.Select = "" Then
´ Hier bekomme ich den Fehler Die Select Eigenschaft des Range Objekts kann nicht zugeordnet
´werden, wenn ich in einem anderen Tabellenblatt als dem aktiven, in dem ich mich gerade befinde einen Wert suche
Exit Sub
Else
rngSuchErgebnis.Select
End If
End If
Next
End Sub
Wo liegt mein Problem? Was kann man machen?
Gruß, und Danke für die Hilfe
Antwort 7 von Boerrt
Hallo,
Habe eine Lösung für dieses Makro im Thread http://www.office-loesung.de/ftopic70052_75_0_asc.php
gefunden.
Leider gibt es noch ein Problem:
Ich hab in meiner Tabelle verbundene Zellen, bei denen mehrere Zeilen miteinander verbunden sind (Bsp.: Zelle A18-20:C18-20)
Wenn ich nach Werten in diesen Zellen suche, bekomme ich folgende Fehlermeldung:
"Objektvariable oder With Blockvariable nicht festgelegt"
Der Fehler ist in der Zeile
Kann man da was machen? Vielen Dank für eure Hilfe
Habe eine Lösung für dieses Makro im Thread http://www.office-loesung.de/ftopic70052_75_0_asc.php
gefunden.
Leider gibt es noch ein Problem:
Ich hab in meiner Tabelle verbundene Zellen, bei denen mehrere Zeilen miteinander verbunden sind (Bsp.: Zelle A18-20:C18-20)
Wenn ich nach Werten in diesen Zellen suche, bekomme ich folgende Fehlermeldung:
"Objektvariable oder With Blockvariable nicht festgelegt"
Der Fehler ist in der Zeile
Loop While Not rngSuchErgebnis Is Nothing And rngSuchErgebnis.Address <> strErsteAdresse
Kann man da was machen? Vielen Dank für eure Hilfe
Antwort 8 von Boerrt
Okay, das Problem habe ich lösen können.
Man muss or den Loop noch
einfügen, dann klappt alles
Gruß,Boerrt
Man muss or den Loop noch
If rngSuchErgebnis Is Nothing Then Exit Do
einfügen, dann klappt alles
Gruß,Boerrt