AW: suchen und ausgabe
08.09.2003 10:50:02
Willie
Kopier den Code einfach in eine Neue Tabelle und trage dort in der Zeile wo die Sterne
sind dein MappenName ein ... makro sucht über alle Blätter!
Gruß
Willie
Eventl muß du noch ein bischen anpassen!
Public
Sub suchen()
Windows("DeineMappe.xls").Activate 'Hier ändern *****
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("Endkundendatenbank.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 & ":CM" & 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
End Sub