AW: ..zB.Archivsuche,Google usw...
07.06.2011 14:14:08
René
Hallo Marc und Robert,
habe jetzt mal ins Archiv geschaut und folgendes gefunden.
Allerdings funktioniert die Taste Abbrechen nicht und die Tabelle mit dem Suchergebnis hat leider nicht die passende Spaltenbreite so das manche Wörter nur halb lesbar sind. Kann man da noch was ändern?
Wäre Euch sehr dankbar.
Mfg René
Private Sub CommandButton7_Click()
Dim c As Range
Dim Suchwert As Variant
Dim ws As Worksheet
Dim ersterFundort As String
Dim i As Integer, z As Long
z = 1
Do
Suchwert = InputBox("Suchbegriff", "Suchbegriff")
Loop While Suchwert = ""
For Each ws In Sheets
If ws.Name = "Suchergebnis" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
Sheets.Add After:=Sheets(Sheets.Count)
Set ws = ActiveSheet
ws.Name = "Suchergebnis"
ws.Cells(1, 1).Value = "Suchergebnis"
ws.Cells(1, 2).Value = "im Tab.blatt"
ws.Cells(1, 3).Value = "Zelladresse"
ws.Cells(1, 4).Value = "Spalte C"
ws.Cells(1, 6).Value = "Spalte E"
For i = 1 To Sheets.Count - 1
Set c = Sheets(i).Cells.Find(what:=Suchwert, lookat:=xlValue)
If Not c Is Nothing Then
Do Until c Is Nothing Or c.Address = ersterFundort
If ersterFundort = "" Then ersterFundort = c.Address
z = z + 1
With ws
.Cells(z, 3).Value = c.Address(False, False)
.Cells(z, 2).Value = Sheets(i).Name
.Hyperlinks.Add Anchor:=.Cells(z, 1), Address:="", _
SubAddress:=Sheets(i).Name & "!" & c.Address(False, False), _
TextToDisplay:=CStr(c)
'Spalten C bis D der gefundenen Zeile kopieren
With Sheets(i)
.Range(.Cells(c.Row, 3), .Cells(c.Row, 6)).Copy _
Destination:=ws.Cells(z, 4)
End With
End With
Set c = Sheets(i).Cells.FindNext(c)
Loop
End If
Set c = Nothing
ersterFundort = ""
Next
End Sub