$100 - Visual Basic Schedule Organizer

Sub Consolidator()
    Dim lng As Long
    Dim rng As Range
    Dim varListItems As Variant
    Dim varExistingList As Variant
    Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets("Control")
        varListItems = Array("Buffet", "Chefs", "Cocktail", "Thirst")
        For lng = 0 To UBound(varListItems)
            On Error Resume Next
            Application.DisplayAlerts = False
            Worksheets(varListItems(lng)).Delete
            Application.DisplayAlerts = True
            Err.Clear: On Error GoTo 0: On Error GoTo -1
            With Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                .Name = varListItems(lng)
                ThisWorkbook.Worksheets("Rawtime").Cells(1, 1).Resize(2, 9).Copy .Cells(2, 1)
                .Range("B:B").Delete
                .Cells(1).Resize(1, 8).Merge
                .Cells(1).Value = .Name
                .Cells(1).HorizontalAlignment = xlCenter
            End With
        Next lng
    End With
    With ThisWorkbook.Worksheets("Rawtime")
        For Each rng In .Range("C4:I" & .Cells(.Rows.Count, 2).End(xlUp).Row)
            If Not IsError(Application.Match(rng.Value, varListItems, 0)) Then
                varExistingList = Worksheets(rng.Value).UsedRange.Columns(1).Cells.Value
                If Not IsError(Application.Match(rng.Parent.Cells(rng.Row - 1, 1).Value, varExistingList, 0)) Then
                    With Worksheets(rng.Value).Cells(Application.Match(rng.Parent.Cells(rng.Row - 1, 1).Value, varExistingList, 0), 1)
                        .Value = rng.Parent.Cells(rng.Row - 1, 1).Value
                        .Offset(, rng.Column - 2).Value = rng.Offset(-1).Value
                    End With
                Else
                    With Worksheets(rng.Value).Cells(Rows.Count, 1).End(xlUp)(2)
                        .Value = rng.Parent.Cells(rng.Row - 1, 1).Value
                        .Offset(, rng.Column - 2).Value = rng.Offset(-1).Value
                    End With
                End If
            End If
        Next rng
    End With
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Schedule").Delete
    Application.DisplayAlerts = True
    Err.Clear: On Error GoTo 0: On Error GoTo -1
    With Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        .Name = "Schedule"
    End With
    Worksheets("Schedule").UsedRange.Clear: lng = 0
    For Each varExistingList In varListItems
        With Worksheets(varExistingList).UsedRange
            .Rows(2).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeBlanks).Interior.Color = 0
            .EntireColumn.AutoFit
            With .Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            .Copy Worksheets("Schedule").Cells(Rows.Count, 1).End(xlUp).Offset(lng): lng = 2
        End With
    Next varExistingList
    Application.Goto Worksheets("Schedule").Cells(1)
    Worksheets("Schedule").UsedRange.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    varExistingList = vbNullString
    Erase varListItems
    Set rng = Nothing
    
End Sub