AW: suchen und kopieren
12.09.2003 08:27:53
Willie
Das makro in eine NeueMappe kopieren und den Namen DeineTabelle änder auf den
Namen deiner Mappe die durchsucht werdne soll es wird die Zeile kopiert....
Gruß
Willie
Public
Sub suchen()
Windows("DeineTabelle.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("DeineTabelle.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
Cells(2, 1).Value = Cells(1, 4).Value
End Sub