AW: suchen über mehrere Blätter
Willie
Hallo Markus ich habe dir hier ein Makro
Das genau das macht, was du willst. Du kannst es in eine Neue Datei
reinmachen und in der 1. Zeile den Namen deiner zu durchsuchenden Tabelle eintragen
Du kannst in der eingabe box den Suchbegriff eingeben und es werden die Daten in deine
Neue Datei untereinander geschrieben.
Gruß
Willie
Rückmeldung wäre super auch im Sinne des Forums!
Public
Sub suchen()
Windows("DeineSuchTabelle.xls").Activate
Dim Zelle As Range, Suchbegriff As String, Adresse As String, zaehler As Integer
Dim index As Integer, Feld() As String, Tabelle() As Integer, Zeile_Spalte() As String
Dim Suche As Variant
i = 3
Suchbegriff = InputBox("Suchbegriff eingeben", "Eingabe")
If Suchbegriff <> "" Then
For index = 1 To Worksheets.Count
With Sheets(index).Cells
Set Zelle = .Find(What:=Trim(Suchbegriff), LookAt:=xlPart)
If Not Zelle Is Nothing Then
Adresse = Zelle.Address
Do
zaehler = zaehler + 1
ReDim Preserve Feld(1 To zaehler)
ReDim Preserve Tabelle(1 To zaehler)
ReDim Preserve Zeile_Spalte(1 To zaehler)
Feld(zaehler) = Sheets(index).Name & " Spalte " & Zelle.Column & " Zeile " & Zelle.Row
Tabelle(zaehler) = index
Zeile_Spalte(zaehler) = Zelle.Address
Set Zelle = .FindNext(Zelle)
Loop While Not Zelle Is Nothing And Zelle.Address <> Adresse
End If
End With
Next
If zaehler > 0 Then
If MsgBox(Suchbegriff & " wurde " & CStr(zaehler) & " mal gefunden." & vbNewLine & "Fundstellen übertragen?", 68, "Information") = 7 Then Exit Sub
Do
For index = 1 To zaehler
Windows("DeineSuchTabelle.xls").Activate
Sheets(Tabelle(index)).Select
Range(Zeile_Spalte(index)).Select
ActiveWindow.ScrollColumn = Selection.Column
ActiveWindow.ScrollRow = Selection.Row
Suche = ActiveWindow.ScrollRow
If Suche > 2 Then
Range("A" & Suche & ":DM" & Suche).Select
Selection.Copy
Blattname = ActiveSheet.Name
ThisWorkbook.Activate
Cells(2, 1).Value = Blattname
Cells(i, 1).Select
i = i + 1
ActiveSheet.Paste
Else
GoTo weiter
End If
weiter:
If zaehler = 1 Then Exit Sub
If index < zaehler Then
'If MsgBox(CStr(index) & ". Fundstelle von " & CStr(zaehler) & ": " & Feld(index) & vbNewLine & "Weitere anzeigen?", 68, "Information") = 7 Then Exit Sub
Else
If MsgBox(CStr(index) & ". Fundstelle von " & CStr(zaehler) & ": " & Feld(index) & vbNewLine & "Nochmal übertragen?", 68, "Information") = 7 Then Exit Do
End If
Next
Loop
Else
MsgBox Suchbegriff & " wurde nicht gefunden", 64, "Information"
End If
End If
ThisWorkbook.Activate
Cells(2, 1).Value = Cells(1, 4).Value
End Sub