title image


Smiley Re: Excel97 VB Anzeige aller Zeilen in denen ein bestimmter Text gefunden wurde
Hallo, anbei ein Programm, mit dem ich alle Blätter einer Excel-Datei durchsuche, Blätter müssen z.T. erst angelegt werden.

Gruß Helmut



Option Explicit '18-06-2005

'23-10-2005 Fehler beseitigt(neue Logik), Blattname eingefügt

'liefert in "Resultat" eine Liste der Suchergebnisse



Public Sub InhalteSuchenHauptprogramm() '12-03-2005

'sucht Zelleninhalte innerhalb einer Excel-Datei in allen Blättern

'und speichert in 'Resultat'

Dim Inhalt As String

Dim Ergebnis As String



Sheets("Resultat").Select

Cells.Select

Selection.Clear 'Löscht Daten

Sheets("Result2").Select

Cells.Select

Selection.Clear 'Löscht Daten



Inhalt = InputBox("Gebe Such-Text ein" & vbLf & vbLf & _

"(Keine Eingabe = Abbruch)") 'Initialisierung, 1.Test

Ergebnis = InhalteSuchen_neu(Inhalt)

Sheets("Resultat").Select

Cells.Select

Selection.Columns.AutoFit

Cells(1, 1).Select

Do

Inhalt = InputBox(Ergebnis) '2., 3.Test....

If Inhalt = "" Then Exit Do 'Abbruchbedingung

Ergebnis = InhalteSuchen_neu(Inhalt) 'Neue Namenssuche

Sheets("Resultat").Select

Cells.Select

Selection.Columns.AutoFit

Cells(1, 1).Select

Loop While Inhalt ""

Cells(1, 1).Select

SpalteEinfügen

End Sub



Public Function InhalteSuchen_neu(Inhalt As String)

'sucht 'Inhalt' in allen Blättern und speichert in 'Resultat'

Dim i As Integer ' Anzahl der Blätter

Static j As Long ' Zeilenzähler, statisch

Dim Zeile As Long

Dim c

Dim FirstAddress



Sheets("Resultat").Select

If Inhalt = "" Then

j = 0

Exit Function

End If

' Sheets.Add.Name = "Resultat"

On Error Resume Next ' Fehlerbehandlung aktivieren.

For i = 1 To Sheets.Count - 3 ' die letzten beiden Tabellen ignorieren

Sheets(i).Select ' Blatt wählen



With Worksheets(i).UsedRange 'Range("a1:z500")

Set c = .Find(Inhalt, LookIn:=xlValues)

If Not c Is Nothing Then

FirstAddress = c.Address

Do

InhalteSuchen_neu = c.Value & ", " & Sheets(i).Name _

& "!" & c.Address & vbLf & InhalteSuchen_neu 'für MsgBox

Rows(c.Row).Copy _

Destination:=Worksheets("Resultat").Cells(j + 1, 1)

Worksheets("Result2").Cells(j + 1, 1) = Sheets(i).Name 'Blattname

' Rows(1).Copy _

' Destination:=Worksheets("Resultat").Cells(j + 1, 1) ''1.Zeile im Blatt

j = j + 1 'liefert jetzt zwei Zeilen

Set c = .FindNext(c)

Loop While Not c Is Nothing And c.Address FirstAddress

End If

End With

Next

' SpalteEinfügen

End Function



Sub SpalteEinfügen() '23-10-2005

'Fügt die in Result2 gespeicherten Blattnamen ein

Sheets("Result2").Select

Columns("A:A").Select

Selection.Copy

Sheets("Resultat").Select

Columns("A:A").Select

Selection.Insert Shift:=xlToRight

Range("A1").Select

ActiveSheet.Paste

Range("E22").Select

End Sub



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: