Office: Arbeitsmappe durchsuchen und gesamte Zeile des gesuchten ausgeben

Hallo,
bin neu in diesem Forum als registrierter User. Bisher also viel gelesen als anonymer.
Mein Problem:
Habe eine Excel Arbeitsmappe die ich mit VBA durchsuche und in einem Arbeitsblatt Namens "Suchbereich" die kpl. Zeile des gefundenen suchwertes ausgeben lassen kann.
Funktioniert auch ganz gut wird jetzt aber immer langsamer.
Dieses VBA durchsucht die gesamte Arbeitsmappe. Es ist aber ausreichend wenn nur in drei Arbeitsblättern (Bezeichnung: Str1, Str2, CR3) gesucht wird.

Wie müsste dieses VBA geändert werden das es so funktionieren würde:


Private Sub Clear_Click()
End Sub

Private Sub Suchen_Click()
Dim wks As Worksheet
Dim rng As Range
Dim strAddress As String
Dim first As Integer
Dim insert(10000) As String
Dim index As Integer
Dim ws As Worksheet

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False




'first bestimmt den Punkt an dem der gefundene Inhalt eingefügt wird.Hier Zeile 14
first = 14
index = -1

For Each wks In Worksheets
Set rng = wks.Cells.Find(TextBox1.Text, lookat:=xlWhole, LookIn:=xlFormulas)
If Not rng Is Nothing Then
strAddress = rng.Address
index = index + 1
insert(index) = wks.name
index = index + 1
insert(index) = rng.row
Do
Set rng = wks.Cells.FindNext(after:=wks.Range(rng.Address).Cells)
If rng.Address = strAddress Then Exit Do
index = index + 1
insert(index) = wks.name
index = index + 1
insert(index) = rng.row
Loop
End If
Next wks

For i = 0 To index
If i Mod 2 = 0 Then
first = first + 1
Worksheets(insert(i)).Rows(insert(i + 1)).Copy Destination:=Worksheets(ActiveSheet.name).Rows(first)
End If
Next i



Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

Private Sub TextBox1_Change()

End Sub



Verstehe leider kein Wort von diesem geschriebenen und denke das mir hier bestimmt jemand von euch Profis helfen kann.

 

Hallo,

nachfolgend der VBA-Code, der nur die 3 erwähnten Arbeitsblätter durchsucht und die Funde zeilenweise ins aktive Arbeitsblatt ausgibt.
Darüber hinaus habe ich im Code noch weitere Vereinfachungen durchgeführt, zB. habe ich die unnötige Zwischenspeicherung in das Array Insert(10000) entfernt.

Code:

Private Sub Clear_Click()
'
End Sub
Private Sub Suchen_Click()
   Dim wks As Worksheet
   Dim rngFund As Range
   Dim strAddress As String
   Dim first As Integer
  '
   With Application
     .Calculation = xlCalculationManual
     .ScreenUpdating = False
   End With
  '
   'first bestimmt den Punkt an dem der gefundene Inhalt eingefügt wird.Hier Zeile 14
   first = 14
  '
   For Each wks In Sheets(Array("Str1", "Str2", "CR3"))
      Set rngFund = wks.Cells.Find(What:=TextBox1.Text, lookat:=xlWhole, LookIn:=xlFormulas)
      If Not rngFund Is Nothing Then
        strAddress = rngFund.Address
        first = first + 1
        rngFund.EntireRow.Copy Destination:=ActiveSheet.Rows(first)
        Do
          Set rngFund = wks.Cells.FindNext(After:=rngFund)
          If rngFund.Address = strAddress Then Exit Do
          first = first + 1
          rngFund.EntireRow.Copy Destination:=ActiveSheet.Rows(first)
        Loop
      End If
   Next wks
 '
   With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
   End With
  '
End Sub

Private Sub TextBox1_Change()
'
End Sub

 

Hallo Anton EXl,

funktioniert genau so wie ich es mir gewünscht habe. Einfach Klasse deine schnelle Hilfe.
Suchergebnis wird nach Klick sofort ausgeben ohne Zeitverlust. Was ja mein Problem war.
Problem gelöst und sogar noch optimiert.
Nochmals vielen, vielen Dank.