Code:
Private Sub Daten_uebertragen()
Const dblTimeVor As Double = 0.3 '30 Minut
Dim strName As String 'column "A" in the source or target sheet in cell "C4"
Dim strDepartment As String 'column "A"
Dim strStart As String 'Starting time - Column B
Dim strEnd As String 'Ending time - Column C
Dim datDateStart As Date
Dim strTimeStart As String
Dim dblTimeStart As Double, dblTimeNew As Double
Dim datDateEnd As Date
Dim strTimeEnd As String
Dim strAMPM As String
Dim lngSpalte As Long
Dim rngDatum As Range, rngName As Range
Dim vAuswahl As Variant
Application.ScreenUpdating = False
For Each wksZiel In wbZiel.Worksheets
Select Case wksZiel.Name
Case "Data"
'please not edit
Case Else
'Name read in target sheet
strName = wksZiel.Cells(4, 3).Value
With wksQuelle
'Look up name in column "A".
Set rngName = .Columns(1).Find(What:=strName, LookIn:=xlValues, lookat:=xlWhole)
If rngName Is Nothing Then
vAuswahl = MsgBox("Name " & strName & " not find in source file!", _
Buttons:=vbAbortRetryIgnore)
If vAuswahl = vbAbort Then GoTo Beenden
Else
lngZeile_Q = rngName.Row + 1
Do Until .Cells(lngZeile_Q, 2) = "" 'the next name is column "B" blank
'Read data from row into variables
strDepartment = .Cells(lngZeile_Q, 1)
strStart = .Cells(lngZeile_Q, 2)
strEnd = .Cells(lngZeile_Q, 3)
'Date from Startdate/-Time determine
datDateStart = DateSerial(Year:=Mid(strStart, 7, 4), Month:=Mid(strStart, 1, 2), Day:=Mid(strStart, 4, 2))
'Time from the start date / time to determine as text
strTimeStart = Trim(Mid(strStart, InStr(1, strStart, " ") + 1))
'Date from the end date / time to determine
datDateEnd = DateSerial(Year:=Mid(strEnd, 7, 4), Month:=Mid(strEnd, 1, 2), Day:=Mid(strEnd, 4, 2))
'Time from the end date / time to determine as text
strTimeEnd = Trim(Mid(strEnd, InStr(1, strEnd, " ") + 1))
'AM / PM of start time separating
strAMPM = Right(strTimeStart, 2)
'Start date set for the target column
If strAMPM = "AM" Then
lngSpalte = 5 'column E
ElseIf strAMPM = "PM" Then
lngSpalte = 7 'column G
End If
If strAMPM = "AM" And strTimeStart = "12:00 AM" Then
Debug.Print Date
End If
With wksZiel
'Start date in column A of the service plan looking
Set rngDatum = .Columns(1).Find(What:=datDateStart, LookIn:=xlValues, lookat:=xlWhole)
'*** START TIME from the bottom part of the
dblTimeStart = CDbl(VBA.Replace(Format(TimeValue(strTimeStart), "hh:mm"), ":", ","))
'Start time correction - time recorded is set to Set Time when 30 minutes before set time
'dblTimeStart = strTimeStart
Select Case dblTimeStart
' *07:00 AM*
Case 0 - dblTimeVor - 0.14 To 0
dblTimeStart = 12
Case 7 - dblTimeVor - 0.14 To 7 '07:00
dblTimeStart = 7
' *08:00 AM*
Case 8 - dblTimeVor - 0.14 To 8 '08:00
dblTimeStart = 8
' *09:00 AM*
Case 9 - dblTimeVor - 0.14 To 9 '09:00
dblTimeStart = 9
' *10:00 AM*
Case 10 - dblTimeVor - 0.14 To 10 '10:00
dblTimeStart = 10
' *10:45 AM*
Case 10.45 - dblTimeVor - 0.14 To 10.45 '10:45
dblTimeStart = 10.45
' *11:00 AM*
Case 11 - dblTimeVor - 0.14 To 11 '11:00
dblTimeStart = 9
' *11:15 AM*
Case 11.15 - dblTimeVor - 0.14 To 11.15 '11:15
dblTimeStart = 11.15
' *11:45 AM*
Case 11.45 - dblTimeVor - 0.14 To 11.45 '11:45
dblTimeStart = 11.45
' *11:30 AM*
Case 11.3 - dblTimeVor - 0.14 To 11.3 '11:30
dblTimeStart = 11#
' *12:00 AM*
Case 12 - dblTimeVor - 0.14 To 12 '12:00
dblTimeStart = 12
' *13:00 PM*
Case 13 - dblTimeVor - 0.14 To 13 '13:00
dblTimeStart = 13
' *14:00 PM*
Case 14 - dblTimeVor - 0.14 To 14 '14:00
dblTimeStart = 14
' *15:00 PM*
Case 15 - dblTimeVor - 0.14 To 15 '15:00
dblTimeStart = 15
' *16:00 PM*
Case 16 - dblTimeVor - 0.14 To 16 '16:00
dblTimeStart = 16
' *16:30 PM*
Case 16.3 - dblTimeVor - 0.14 To 16.3 '16:30
dblTimeStart = 16.3
' *17:00 PM*
Case 17 - dblTimeVor - 0.14 To 17 '17:00
dblTimeStart = 17
' *17:30 PM*
Case 17.3 - dblTimeVor - 0.14 To 17.3 '17:30
dblTimeStart = 17.3
' *17:45 PM*
Case 17.45 - dblTimeVor - 0.14 To 17.45 '17:45
dblTimeStart = 17.45
' *18:00 PM*
Case 18 - dblTimeVor - 0.14 To 18 '18:00
dblTimeStart = 18
' *18:30 PM*
Case 18.3 - dblTimeVor - 0.14 To 18.3 '18:30
dblTimeStart = 18.3
End Select
'*** END TIME from the bottom part of the
'*****Command as the name displayed in window****
dblTimeNew = Application.InputBox(Prompt:="Starting time :" & strStart & vbLf & _
"Ending time: " & strEnd & vbLf _
& vbLf & "(Hours and minutes separated by decimal)", _
Title:="Start time correct - " & strName & " - " & strStart, _
Default:=Format(dblTimeStart, "0.00"), Type:=1)
'*****Command as the name displayed in window*****
If rngDatum Is Nothing Then
MsgBox "Datum " & datDateStart & " im Dienstplan nicht gefunden"
Else
'Start and end time separated by commas registered as number
lngZeile_Z = rngDatum.Row
dblTimeStart = CDbl(VBA.Replace(Format(TimeValue(strTimeStart), "hh:mm"), ":", ","))
'Start time correction - time recorded is set to target time, _
when up to 30 minutes before set time
dblTimeStart = dblTimeNew
'''' End If
''''' End Select
.Cells(lngZeile_Z, lngSpalte) = dblTimeStart
.Cells(lngZeile_Z, lngSpalte + 1) = _
CDbl(VBA.Replace(Format(TimeValue(strTimeEnd), "hh:mm"), ":", ","))
End If
End With
lngZeile_Q = lngZeile_Q + 1
Loop
End If
End With
End Select
Next
Beenden:
Set wksSteuer = Nothing: Set rngDatum = Nothing
Set wbQuelle = Nothing: Set wksQuelle = Nothing
Set wbZiel = Nothing: Set wksZiel = Nothing
Application.ScreenUpdating = False
End Sub