|
Ups. Hier das ganze nochmal. Sorry
Option Explicit
Dim WsZiel As Worksheet, WsNum As Worksheet
Sub Zeilen()
Dim rngU As Range, c As Range, rngZ As Range
Dim FA As String, lrow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set WsZiel = IsKopie
With WsZiel
On Error Resume Next
lrow = 1
lrow = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row + 1
On Error GoTo 0
End With
For Each WsNum In Sheets
If IsNumeric(WsNum.Name) Then
Set rngU = WsNum.UsedRange
With rngU
Set c = .Find("Qualität", LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
FA = c.Address
Do
c.EntireRow.Copy WsZiel.Cells(lrow, 1)
lrow = lrow + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FA
End If
End With
End If
Next WsNum
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Private Function IsKopie() As Worksheet
Dim wskopie As Worksheet
On Error Resume Next
Sheets("Kopie").Activate
If Err.Number > 0 Then
Sheets.Add Before:=Sheets(1)
ActiveSheet.Name = "Kopie"
End If
On Error GoTo 0
Set IsKopie = ActiveSheet
End Function
|