Option Explicit
Public Sub subImportAndSplitData()
Dim i As Integer
Dim WsData As Worksheet
Dim arrData() As Variant
Dim arrDate() As String
Dim rngLoc As Range
ActiveWorkbook.Save
Call subCreateRoleColoursTab
Set WsData = Worksheets("Structured")
WsData.Columns("D").Replace What:="SUP", Replacement:="ASUP", SearchOrder:=xlByRows, LookAt:=xlWhole, MatchCase:=True
arrData = WsData.UsedRange
For i = LBound(arrData) To UBound(arrData)
If arrData(i, 1) = "Loc" Then
Set rngLoc = WsData.Range("A" & i)
With rngLoc
arrDate = Split(.Offset(-4, 0).Value, " ")
Call subCreateWorksheets(rngLoc, arrDate(1) & " " & arrDate(2))
End With
End If
Next i
MsgBox "Data has been processed and separate sheets been created.", vbOKOnly, "Confirmation"
End Sub
Private Sub subCreateWorksheets(rng As Range, strWorksheetName As String)
Dim Ws As Worksheet
Set Ws = fncCreateSheet(ActiveWorkbook, strWorksheetName)
With rng.CurrentRegion
Ws.Range("A1").Formula2 = "=CHOOSECOLS(VSTACK(TAKE('" & .Parent.Name & "'!" & .Address & ",1),SORT(" & _
"'" & .Parent.Name & "'!" & .Offset(1, 0).Resize(.Rows.Count - 1.7).Address & ",{4,2,3})),6,5,7,4,2,3,1)"
End With
With Ws.Range("A1").CurrentRegion
.Value = .Value
.Columns("E:F").NumberFormat = "HH:MM"
End With
Call subSplitByRole(Ws)
Call subAddHeaderBlock(Ws)
End Sub
Private Sub subFormatSheet(Ws As Worksheet)
With Ws.Range("A1").CurrentRegion
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = vbBlack
End With
.RowHeight = 27
.Rows(1).Font.Bold = True
.VerticalAlignment = xlCenter
.IndentLevel = 1
.EntireColumn.AutoFit
End With
End Sub
Public Sub subSplitByRole(Ws As Worksheet)
Dim arrData() As Variant
Dim i As Integer
Dim strRole As String
Dim lngColour As Long
Dim rngColour As Range
Ws.Activate
Call subFormatSheet(Ws)
arrData = Ws.Range("A1").CurrentRegion
strRole = arrData(UBound(arrData), 4)
For i = UBound(arrData) To 1 Step -1
If arrData(i, 4) <> strRole Then
Ws.Range("A" & i + 1).EntireRow.Insert
With Ws.Range("A" & i + 1)
With .Resize(1, 7)
.Interior.Color = fncGetColour(strRole)
.Merge
With .Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = vbBlack
End With
End With
.Value = strRole
.Font.Bold = True
End With
strRole = arrData(i, 4)
End If
Next i
End Sub
Public Function fncGetColour(strRole As String) As Long
Dim rngColour As Range
fncGetColour = 16777215
Set rngColour = Worksheets("Role Colours").Range("A:A").Find(strRole, LookIn:=xlValues, LookAt:=xlWhole)
If Not rngColour Is Nothing Then
fncGetColour = rngColour.Interior.Color
End If
End Function
Public Sub subCreateRoleColoursTab()
Dim Ws As Worksheet
Dim rng As Range
If Not fncDoesWorksheetExist(ThisWorkbook, "Role Colours") Then
Set Ws = fncCreateSheet(ThisWorkbook, "Role Colours")
For Each rng In Ws.Range("A2:A6").Cells
rng.Value = Choose(rng.Row - 1, "AMOR", "ASUP", "BATT", "HOST", "WAIT")
rng.Interior.Color = Choose(rng.Row - 1, 7592334, 65535, 49407, 14524132, 14791492)
Next rng
Ws.Range("A1").Value = "Role"
Call subFormatSheet(Ws)
End If
End Sub
Public Function fncCreateSheet(Wb As Workbook, strWorksheet As String) As Worksheet
Application.DisplayAlerts = False
On Error Resume Next
Wb.Worksheets(strWorksheet).Delete
On Error GoTo 0
Application.DisplayAlerts = True
Wb.Sheets.Add after:=Wb.Sheets(Wb.Sheets.Count)
ActiveSheet.Name = strWorksheet
Set fncCreateSheet = ActiveSheet
End Function
Public Function fncDoesWorksheetExist(Wb As Workbook, strWorksheet As String) As Boolean
Dim Ws As Worksheet
For Each Ws In Wb.Worksheets
If Ws.Name = strWorksheet Then
fncDoesWorksheetExist = True
End If
Next Ws
End Function
Public Sub subAddHeaderBlock(Ws As Worksheet)
Dim intColumns As Integer
Dim intRows As Integer
Dim i As Integer
With Ws
.Activate
.Range("H1:L1").Value = Array("Revised", "Time", 15, 39, 45)
With .Range("A1").CurrentRegion
intColumns = .Columns.Count
intRows = .Rows.Count
With .Rows(1)
.Interior.Color = RGB(219, 219, 219)
.VerticalAlignment = xlCenter
.IndentLevel = 1
.Font.Bold = True
End With
End With
With .Range("H1").Resize(intRows, 5).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = vbBlack
End With
.Range("1:5").EntireRow.Insert
.Range("A3").Value = "Breakfast"
.Range("A4").Value = "Lunch"
.Range("A5").Value = "Dinner"
With .Range("B2")
.Value = "Bookings"
.EntireColumn.AutoFit
End With
For i = 2 To 5
.Range("C" & i & ":I" & i).Merge
Next i
.Range("C2").Value = "Function / Special Event"
With .Range("J5:L5")
.Merge
.Value = "Breaks"
End With
With .Range("A1").Resize(5, intColumns)
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = vbBlack
End With
.RowHeight = 27
.VerticalAlignment = xlCenter
.IndentLevel = 1
.Font.Bold = True
With .Rows(1)
.Merge
.Interior.Color = 16115392
.Value = Ws.Name
.NumberFormat = fncGetCustomDateFormat(Ws.Name)
.RowHeight = 44
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Font.Size = 20
End With
End With
.Range("B2").EntireColumn.AutoFit
.Range("C2").HorizontalAlignment = xlCenter
.Range("C3:I5").Borders(xlInsideVertical).LineStyle = xlNone
.Range("A7").Select
ActiveWindow.FreezePanes = True
End With
End Sub
Private Function fncGetCustomDateFormat(dteDate As Date) As String
Select Case Day(dteDate)
Case Is = 1, 21, 31 'st
fncGetCustomDateFormat = "DDDD d""st"" MMMM, YYYY"
Case Is = 2, 22 'nd
fncGetCustomDateFormat = "DDDD d""nd"" MMMM, YYYY"
Case Is = 3, 23 'rd
fncGetCustomDateFormat = "DDDD d""rd"" MMMM, YYYY"
Case 4 To 20, 24 To 30 'th
fncGetCustomDateFormat = "DDDD d""th"" MMMM, YYYY"
End Select
End Function
