AW: Zeilen nach Kriterien ausschneiden
14.08.2006 11:02:20
fcs
Hallo Otto,
hier mein Vorschlag, mit den Hauptprozeduren gibts du den Suchbegriff, die Spalte und die Titelzeilen vor.
Dann wird die Subroutine aufgerufen.
Sub Stahl_suchen_Spalte3()
'Sucht im aktiven Blatt in Spalte3 nach dem Wort "Stahl" und kopiert Zeilen in ein neues Blatt
'Anzahl Titelzeilen = 1
Call SuchenBegriff("Stahl", 3, 1)
End Sub
Sub Stahl_suchen()
'Sucht im aktiven Blatt (Spalte = 0) nach dem Wort "Stahl" und kopiert Zeilen in ein neues Blatt
'Anzahl Titelzeilen = 1
Call SuchenBegriff("Stahl", 0, 1)
End Sub
Private Sub SuchenBegriff(Suchen As Variant, Spalte As Integer, Titelzeilen As Integer)
'Sucht im aktiven Blatt nach dem Suchbegriff und kopiert Zeilen in ein neues Blatt
'Bei Spalte = 0 wird im gesamten Blatt gesucht
Dim wksNeu As Worksheet, wksAkt As Worksheet, Zelle As Range
Dim Bereich As Range, Adresse1 As String, Zeile As Long
Suchen = "Stahl"
Set wksAkt = ActiveSheet
ZeileAkt = Titelzeilen + 1 'Zeile ab der im aktuellen Blatt die Suche beginnen soll
ZeileNeu = Titelzeilen + 1 'Zeile ab der im neuen Blatt Daten eingefügt werden sollen
With wksAkt
' Datenbereich im aktuellen Blatt
If Spalte = 0 Then 'Gesamtes Blatt
Set Bereich = .Range(.Cells(ZeileAkt, 1), .Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, _
.UsedRange.Column + .UsedRange.Columns.Count - 1))
Else 'nur in Spalte
Set Bereich = .Range(.Cells(ZeileAkt, Spalte), .Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, Spalte))
End If
Set Zelle = Bereich.Find(What:=Suchen, LookIn:=xlValues, Lookat:=xlPart, SearchOrder:=xlByRows)
If Zelle Is Nothing Then
MsgBox "Der Suchbegriff: "" & Suchen & "" wurde nicht gefunden"
Exit Sub
Else
ActiveWorkbook.Worksheets.Add After:=wksAkt
Set wksNeu = ActiveSheet
If Titelzeilen > 0 Then
'Titelzeilen werden kopiert
wksAkt.Range(wksAkt.Cells(1, 1), wksAkt.Cells(1, Titelzeilen)).EntireRow.Copy Destination:=wksNeu.Cells(1, 1)
wksNeu.Cells(Titelzeilen + 1, 1).Select
Application.ActiveWindow.FreezePanes = True
End If
Application.ScreenUpdating = False
Adresse1 = Zelle.Address
Zeile = Zelle.Row
Do
wksAkt.Rows(Zelle.Row).Copy Destination:=wksNeu.Cells(ZeileNeu, 1)
ZeileNeu = ZeileNeu + 1
' Falls Suchbegriff mehrfach in Zeile vorkommt, dann nicht kopieren
Do
Set Zelle = Bereich.FindNext(After:=Zelle)
Loop Until Zelle.Row <> Zeile Or Zelle.Address = Adresse1
Zeile = Zelle.Row
Loop Until Zelle.Address = Adresse1
End If
Application.CutCopyMode = False
Application.ScreenUpdating = False
End With
End Sub
gruss
Franz