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, 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,5,6})),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)
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
Private 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
