|
Moin,
einfach&geschmacklos&ungetestet
LG
Sub myCopy_Cond()
Dim ws As Worksheet, wz As Worksheet
Dim lnglrw As Long 'jeweils letzte Zeile, Zeilen sind LONG
Dim lngnrw As Long
Dim i As Long
Dim WB As Workbook: Set WB = ActiveWorkbook
With WB
On Error Resume Next
Set wz = .Sheets("Output")
On Error GoTo 0
If wz Is Nothing Then
Set wz = .Sheets.Add(After:=.Sheets(.Sheets.Count))
wz.Name = "Output"
Else
wz.Cells.Clear
End If
lngnrw = 1
For Each ws In .Sheets
If ws.Index <> wz.Index Then
With ws
'nicht nach Spalte "O", könnte ja leer sein
On Error Resume Next
lnglrw = 1 'ditto
lnglrw = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row
On Error GoTo 0
For i = 1 To lnglrw
If Not IsError(.Cells(i, 15).Value) Then
If .Cells(i, 15).Value <> "" Then
'Reihenfolge D, E, O
.Cells(i, 4).Copy wz.Cells(lngnrw, 1)
.Cells(i, 5).Copy wz.Cells(lngnrw, 2)
'eigentlich ist das Kopieren von Zellen mit Formeln Nato;)
'.Cells(i, 15).Copy wz.Cells(lngnrw, 15)
wz.Cells(lngnrw, 3).Value = .Cells(i, 15).Value
lngnrw = lngnrw + 1
End If
End If
Next i
End With
End If
Next ws
End With
End Sub
|