Aber Ich weiß nicht wie ich das Ergebniss Kopieren kann. Bei mir Kopieren sich immer alle Zeilen mit.
Bitte immer den gesamten Quelltext posten - beim nächsten Mal.
Option Explicit
Sub Test()
Dim QSheet As Excel.Worksheet
Dim KopieRange As Excel.Range
Dim loLetzte As Long
Dim SuchZeile As Long
'Set QSheet = ThisWorkbook.Worksheets(...)
With QSheet
loLetzte = .Cells(.Rows.Count, "A").End(xlUp).Row
Set KopieRange = Nothing
For SuchZeile = 1 To loLetzte
If .Cells(SuchZeile, "J").Value = 31 _
Or .Cells(SuchZeile, "J").Value = 61 _
Then
If Not KopieRange Is Nothing Then
Set KopieRange = Union(KopieRange, .Rows(SuchZeile))
Else
Set KopieRange = .Rows(SuchZeile)
End If
End If
Next
If Not KopieRange Is Nothing Then
'Call KopieRange.Copy(Destination:=Worksheets(Ort).Range("A1"))
End If
End With
End Sub
Grüße
|