Sub btnUpdte_Click()
Dim x, Dates, Times(1 To 48), i As Long, ii As Long, iii As Long, iv As Long, v As Long, vi As Long, vii As Long
vi = 1
x = Sheet2.Cells(1).CurrentRegion
With Sheet1
For i = 1 To 48
Times(i) = CStr(Val(.Range("Times").Rows(i)))
Next
Dates = Application.Transpose(.[Dates])
End With
Application.ScreenUpdating = 0
With [Schedule]
.UnMerge
.Interior.Color = xlNone
.ClearContents
For i = 2 To UBound(x, 1)
If CDate(Format(x(i, 10), "mm/dd/yyyy")) >= [StartDate] And CDate(Format(x(i, 9), "mm/dd/yyyy")) <= [EndDate] Or Format(x(i, 9), "mm/dd/yyyy") < [EndDate] + 1 Then
x(i, 9) = Application.MRound(x(i, 9), "0:30")
x(i, 10) = Application.MRound(x(i, 10), "0:30")
If x(i, 9) <= [StartDate] Then
ddate = CDbl(CDate(Format(x(i, 10), "mm/dd/yyyy")))
iv = Application.Match(ddate, Dates, 1)
Else
ddate = CDbl(CDate(Format(x(i, 9), "mm/dd/yyyy")))
iv = Application.Match(ddate, Dates, 1)
End If
sStart = CStr(CDbl(CDate(Format(x(i, 9), "hh:mm"))))
ii = Application.Match(sStart, Times, 0)
sEnd = CStr(CDbl(CDate(Format(x(i, 10), "hh:mm"))))
iii = Application.Match(sEnd, Times, 0)
If x(i, 9) < [StartDate] Then ii = 1
If x(i, 10) >= [StartDate] + vi Then
vii = iii: iii = 49
End If
With .Cells(ii, iv).Resize(Abs((iii - ii)))
v = Application.Match(x(i, 12), [Codes], 0)
[Codes].Rows(v).Copy: .PasteSpecial xlPasteFormats
.Merge
.Value = x(i, 11)
End With
If x(i, 10) >= [StartDate] + vi And x(i, 10) < [EndDate] + 1 Then
With .Cells(1, iv + 1).Resize(vii - 1)
v = Application.Match(x(i, 12), [Codes], 0)
[Codes].Rows(v).Copy: .PasteSpecial xlPasteFormats
.Merge
.Value = x(i, 11)
End With
End If
If x(i, 10) >= [StartDate] + vi Then vi = vi + 1
If vi > 7 Then Exit For
End If
Next
Application.Goto .Parent.[a1]
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
s = Target.Address
Set r = Range(s)
If Target.Count > 1 Then Exit Sub
If Target.Column = 12 And Target.Row > 2 Then
Application.EnableEvents = 0
i = Application.Match(Target, [Codes], 0)
[Codes].Rows(i).Copy: Target.PasteSpecial xlPasteFormats
With Application
.CutCopyMode = 0
.EnableEvents = 1
End With
End If
End Sub
Bookmarks