Sub ProcessEventData()
Dim ws As Worksheet
Dim lastRow As Long
Dim colSegment As Range, colStart As Range, colEnd As Range
Dim cell As Range
' Set worksheet to active sheet
Set ws = ActiveSheet
' Find last row in the sheet
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Find original columns for Segment, Start Time, End Time
Set colSegment = ws.Rows(1).Find("Segment", LookAt:=xlWhole)
Set colStart = ws.Rows(1).Find("Start Time", LookAt:=xlWhole)
Set colEnd = ws.Rows(1).Find("End Time", LookAt:=xlWhole)
' Insert new columns for Segment, Start Time, End Time at the beginning (shift
existing columns to the right)
ws.Columns("A:C").Insert Shift:=xlToRight
' Set headers for new columns
ws.Range("A1").Value = "Segment"
ws.Range("B1").Value = "Start Time"
ws.Range("C1").Value = "End Time"
' Move the data from the original columns to the new columns (starting from row
2, avoid headers)
If Not colSegment Is Nothing Then
ws.Range(ws.Cells(2, colSegment.Column), ws.Cells(lastRow,
colSegment.Column)).Copy
ws.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
End If
If Not colStart Is Nothing Then
ws.Range(ws.Cells(2, colStart.Column), ws.Cells(lastRow,
colStart.Column)).Copy
ws.Cells(2, 2).PasteSpecial Paste:=xlPasteValues
End If
If Not colEnd Is Nothing Then
ws.Range(ws.Cells(2, colEnd.Column), ws.Cells(lastRow, colEnd.Column)).Copy
ws.Cells(2, 3).PasteSpecial Paste:=xlPasteValues
End If
Application.CutCopyMode = False ' Clear the clipboard to prevent flickering
' Now remove the old "Segment", "Start Time", "End Time" columns to avoid
duplication
On Error Resume Next
If Not colSegment Is Nothing Then colSegment.EntireColumn.Delete
If Not colStart Is Nothing Then colStart.EntireColumn.Delete
If Not colEnd Is Nothing Then colEnd.EntireColumn.Delete
On Error GoTo 0
' Format Start Time and End Time to add space between numbers and AM/PM
For Each cell In ws.Range("B2:B" & lastRow)
If InStr(cell.Value, "am") > 0 Then
cell.Value = Replace(cell.Value, "am", " AM")
ElseIf InStr(cell.Value, "pm") > 0 Then
cell.Value = Replace(cell.Value, "pm", " PM")
End If
Next cell
For Each cell In ws.Range("C2:C" & lastRow)
If InStr(cell.Value, "am") > 0 Then
cell.Value = Replace(cell.Value, "am", " AM")
ElseIf InStr(cell.Value, "pm") > 0 Then
cell.Value = Replace(cell.Value, "pm", " PM")
End If
Next cell
' Delete Inventoried and Priced columns if they exist
On Error Resume Next
ws.Rows(1).Find("Inventoried", LookAt:=xlWhole).EntireColumn.Delete
ws.Rows(1).Find("Priced", LookAt:=xlWhole).EntireColumn.Delete
On Error GoTo 0
' Apply formatting based on criteria
For Each cell In ws.Range("A2:A" & lastRow)
Select Case True
' Gray color for "hidden" and "crew only" events
Case LCase(cell.Value) Like "hidden", LCase(cell.Value) Like "crew
only"
cell.EntireRow.Interior.Color = RGB(169, 169, 169) ' Gray
' Blue color for "entertainment"
Case LCase(cell.Value) Like "entertainment"
cell.EntireRow.Interior.Color = RGB(0, 0, 255) ' Blue
' Purple color for "F & B" events
Case LCase(cell.Value) Like "f & b"
cell.EntireRow.Interior.Color = RGB(128, 0, 128) ' Purple
' Red color for specific event categories
Case LCase(cell.Value) Like "spa" Or LCase(cell.Value) Like "shops" Or
_
LCase(cell.Value) Like "effy" Or LCase(cell.Value) Like "art
gallery" Or _
LCase(cell.Value) Like "watches"
cell.EntireRow.Interior.Color = RGB(255, 0, 0) ' Red
End Select
Next cell
MsgBox "Event Data Processing Complete!", vbInformation
End Sub
