Werte übertragen
15.03.2012 19:50:38
Erich
Hi,
probier mal diese beiden:
Option Explicit
Sub kopierenAb15()
Dim rngC As Range, lngZ As Long
lngZ = 15
'Application.ScreenUpdating = False
With Sheets("Tabelle1")
For Each rngC In .Range(.Cells(8, 2), .Cells(Rows.Count, 2).End(xlUp))
If rngC.Offset(, 4) = 1 Then
If lngZ > 30 Then
MsgBox "Keine Ausgabe unter Zeile 30 - Abbruch", vbCritical
Exit For
End If
rngC.Resize(, 4).Copy
Sheets("Tabelle2").Cells(lngZ, 1).PasteSpecial xlValues
lngZ = lngZ + 1
End If
Next
Application.CutCopyMode = False 'Kopierrahmen deaktivieren
End With
'Application.ScreenUpdating = True
End Sub
Sub NurWerteRuebertragenAb15()
Dim rngQ As Range, lngZ As Long, rngC As Range
With Sheets("Tabelle1")
Set rngQ = .Range(.Cells(8, 2), .Cells(Rows.Count, 2).End(xlUp))
End With
' Application.ScreenUpdating = False
With Sheets("Tabelle2")
lngZ = 15
For Each rngC In rngQ
If rngC.Offset(, 4) = 1 Then
If lngZ > 30 Then
MsgBox "Keine Ausgabe unter Zeile 30 - Abbruch", vbCritical
Exit For
End If
.Cells(lngZ, 2).Resize(, 4) = rngC.Resize(, 4).Value
lngZ = lngZ + 1
End If
Next
End With
'Application.ScreenUpdating = True
End Sub
Nicht mehr nur so nebenbei, sondern ernsthaft:
Ist der erste Tag des Jahres jetzt klar? Ich meine
https://www.herber.de/forum/archiv/1252to1256/t1254344.htm
Und antwortest du auch noch hier - wo es auch um das Kopieren dieses Bereichs ging?
https://www.herber.de/forum/archiv/1252to1256/t1254656.htm
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich