AW: Kopieren wenn Spalte O Uhrzeit kleiner als enthält
08.07.2013 11:48:53
fcs
Hallo Johannes,
hier zwei makros, die die Zeilen aus der Quelle Zeilen bzw. Blockweise in die Zieltabellen kopieren.
Den Vorschlag von Klaus (Hilfsspalte + Autofilter) solltest du wählen, wenn du sehr viele Zeilen in der Quelltabelle hast. Da dann die Zeilenselektion in einem Block erfolgt und kopiert werden kann.
Gruß
Franz
Sub DatenTeilen()
'Jede Zeile nach Prüfung einzeln kopieren
Dim wksData As Worksheet, wksFrueh As Worksheet, wksSpaet As Worksheet
Dim Zeile_D As Long, Zeile_F As Long, Zeile_S As Long
Dim datZeit As Date, datGrenzzeit As Date
Set wksData = ActiveWorkbook.Worksheets("InventoryDaten")
Set wksFrueh = ActiveWorkbook.Worksheets("InventoryDaten früh")
Set wksSpaet = ActiveWorkbook.Worksheets("InventoryDaten spät")
With wksFrueh
Zeile_F = .Cells(.Rows.Count, 15).End(xlUp).Row
If Not IsEmpty(.Cells(Zeile_F, 15)) Then
Zeile_F = Zeile_F + 1
End If
End With
With wksSpaet
Zeile_S = .Cells(.Rows.Count, 15).End(xlUp).Row
If Not IsEmpty(.Cells(Zeile_S, 15)) Then
Zeile_S = Zeile_S + 1
End If
End With
datGrenzzeit = TimeSerial(Hour:=14, Minute:=30, Second:=0)
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With wksData
For Zeile_D = 1 To .Cells(.Rows.Count, 15).End(xlUp).Row
If IsDate(.Cells(Zeile_D, 15)) Then
datZeit = CDate(Format(.Cells(Zeile_D, 15), "hh:mm:ss"))
If datZeit > datGrenzzeit Then
.Rows(Zeile_D).Copy Destination:=wksSpaet.Cells(Zeile_S, 1)
Zeile_S = Zeile_S + 1
Else
.Rows(Zeile_D).Copy Destination:=wksFrueh.Cells(Zeile_F, 1)
Zeile_F = Zeile_F + 1
End If
End If
Next Zeile_D
End With
Fehler:
With Err
Select Case .Number
Case 0
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
Sub DatenTeilen_Variante()
'Zeilenblöcke nach Prüfung blockweise kopieren - läuft etwas schneller als Zeilenweise
Dim wksData As Worksheet, wksFrueh As Worksheet, wksSpaet As Worksheet
Dim Zeile_D As Long, Zeile_F As Long, Zeile_S As Long, Zeile_1 As Long, Zeile_2 As Long
Dim Zeile_L As Long
Dim bolSpaet As Boolean
Dim datZeit As Date, datGrenzzeit As Date
Set wksData = ActiveWorkbook.Worksheets("InventoryDaten")
Set wksFrueh = ActiveWorkbook.Worksheets("InventoryDaten früh")
Set wksSpaet = ActiveWorkbook.Worksheets("InventoryDaten spät")
With wksFrueh
Zeile_F = .Cells(.Rows.Count, 15).End(xlUp).Row
If Not IsEmpty(.Cells(Zeile_F, 15)) Then
Zeile_F = Zeile_F + 1
End If
End With
With wksSpaet
Zeile_S = .Cells(.Rows.Count, 15).End(xlUp).Row
If Not IsEmpty(.Cells(Zeile_S, 15)) Then
Zeile_S = Zeile_S + 1
End If
End With
datGrenzzeit = TimeSerial(Hour:=14, Minute:=30, Second:=0)
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With wksData
Zeile_L = .Cells(.Rows.Count, 15).End(xlUp).Row
For Zeile_D = 1 To Zeile_L
If IsDate(.Cells(Zeile_D, 15)) Then
datZeit = CDate(Format(.Cells(Zeile_D, 15), "hh:mm:ss"))
If Zeile_1 = 0 Then
bolSpaet = (datZeit > datGrenzzeit)
Zeile_1 = Zeile_D
Zeile_2 = Zeile_1
Else
If bolSpaet = (datZeit > datGrenzzeit) Then
Zeile_2 = Zeile_D
Else
If bolSpaet Then
.Range(.Rows(Zeile_1), .Rows(Zeile_2)).Copy Destination:=wksSpaet.Cells(Zeile_S, _
1)
Zeile_S = Zeile_S + Zeile_2 - Zeile_1 + 1
Else
.Range(.Rows(Zeile_1), .Rows(Zeile_2)).Copy Destination:=wksFrueh.Cells(Zeile_F, _
1)
Zeile_F = Zeile_F + Zeile_2 - Zeile_1 + 1
End If
bolSpaet = (datZeit > datGrenzzeit)
Zeile_1 = Zeile_D
Zeile_2 = Zeile_1
End If
End If
End If
Next Zeile_D
Zeile_2 = Zeile_L
If bolSpaet Then
.Range(.Rows(Zeile_1), .Rows(Zeile_2)).Copy Destination:=wksSpaet.Cells(Zeile_S, 1)
Zeile_F = Zeile_F + Zeile_2 - Zeile_1 + 1
Else
.Range(.Rows(Zeile_1), .Rows(Zeile_2)).Copy Destination:=wksSpaet.Cells(Zeile_S, 1)
Zeile_S = Zeile_S + Zeile_2 - Zeile_1 + 1
End If
End With
Fehler:
With Err
Select Case .Number
Case 0
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub