Option Explicit
' global constants
' worksheet & ranges
Global Const gksNoDataWS = "0"
Global Const gksArea = "AreaTable"
Global Const gksColor = "AreaColorList"
Global Const gksTime = "AreaTimeList"
Global Const gksRow = "AreaRowList"
Global Const gksTiming = "TimingList"
Global Const gksParkingI = "ParkingInputTable"
Global Const gksVehicle = "VehicleList"
Global Const gksParkingO = "ParkingOutputTable"
' public declarations
' ranges
Dim grngA As Range, grngAC As Range, grngAT As Range, grngAR As Range, grngT As Range
Dim grngPI As Range, grngV As Range, grngPO As Range
Sub GonnaGetParkedAllTheTimeIWant_GotIt(Optional pvWS As Variant)
'
' constants
' other
Const kiAreaColor = 1
Const kiAreaTime = 2
Const kiColorIndex = 24
Const ksPattern = "Parking Pattern"
Const ksApostrophe = "'"
Const ksDollar = "$"
'
' declarations
Dim rng1 As Range, rng2 As Range
' arrays
Dim sColor() As String, iTime() As Integer, iRow() As Integer, dTiming() As Date
Dim sVehicle() As String, sParkTime()
' others
Dim sWS As String, iColor As Integer, iTiming As Integer
Dim I As Long, J As Long, K As Long, L As Long, M As Long, N As Long, O As Long
Dim A As String
'
' start
If IsMissing(pvWS) Then sWS = "" Else sWS = CStr(pvWS)
'
' process
For I = 1 To Worksheets.Count
With Worksheets(I)
If .Name <> gksNoDataWS Then
If sWS = "" Or .Name = sWS Then
'
' initialize
' ranges
Set grngA = .Range(gksArea)
Set grngAC = .Range(gksColor)
Set grngAT = .Range(gksTime)
Set grngAR = .Range(gksRow)
Set grngT = .Range(gksTiming)
Set grngPI = .Range(gksParkingI)
Set grngV = .Range(gksVehicle)
Set grngPO = .Range(gksParkingO)
If grngV.Rows.Count > 1 Then
With grngV
Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
End With
With grngPO
Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
End With
End If
' arrays
With grngA
iColor = .Rows.Count
ReDim sColor(iColor), iTime(iColor)
For K = 1 To iColor
sColor(K) = .Cells(K, 1).Value
iTime(K) = .Cells(K, 2).Value
Next K
End With
With grngT
iTiming = .Columns.Count
ReDim dTiming(iTiming)
For K = 1 To iTiming
dTiming(K) = .Cells(1, K).Value
Next K
End With
' titles
Set rng1 = grngPO.Cells(1, 1)
Application.Union(grngV, grngPO).EntireColumn.Borders.LineStyle = xlNone
Application.Union(grngV, grngPO).EntireColumn.HorizontalAlignment = xlLeft
Range(rng1.Offset(-3, 0), rng1.Offset(-2, grngPO.Columns.Count)).Interior.ColorIndex = xlNone
Range(rng1.Offset(-3, 0), rng1.Offset(-0, grngPO.Columns.Count)).ClearContents
For K = 1 To iColor
L = (K - 1) * (iTiming + 1)
M = L + iTiming
Set rng2 = grngAC.Cells(K, 1)
Range(rng1.Offset(-3, L), rng1.Offset(-3, M)).Value = sColor(K)
Range(rng1.Offset(-3, L), rng1.Offset(-3, M)).Interior.Color = rng2.Interior.Color
Range(rng1.Offset(-2, L + 1), rng1.Offset(-2, M)).Interior.ColorIndex = kiColorIndex
rng1.Offset(0, L).Value = ksPattern
N = 0
For O = 1 To iTiming
rng1.Offset(-2, L + O).Value = N & "-" & N + iTime(K) & " hrs"
N = N + iTime(K)
rng1.Offset(0, L + O).Value = N
Next O
Next K
'
' do the job
J = 0
ReDim sVehicle(J)
ReDim sParkTime(iColor, J)
' read input
For K = 2 To grngPI.Rows.Count
' area
A = grngPI.Cells(K, 1).Value
For L = 1 To iColor
If A = sColor(L) Then Exit For
Next L
If L > iColor Then
MsgBox "Unknown area for all vehicles at row " & _
grngPI.Cells(K, 1).Address(False, False).Row & _
" of worgksheet " & .Name, _
vbApplicationModal + vbCritical + vbOKOnly, "Area error"
End If
If L <= iColor Then
' data
For M = 2 To grngPI.Columns.Count
' vehicle
A = grngPI.Cells(K, M).Value
If A <> "" Then
' new?
For N = 1 To J
If A = sVehicle(N) Then Exit For
Next N
If N > J Then
J = J + 1
ReDim Preserve sVehicle(J)
ReDim Preserve sParkTime(iColor, J)
sVehicle(J) = A
For O = 1 To iColor
sParkTime(O, J) = String(iTiming, "0")
Next O
End If
' time
If Mid(sParkTime(L, N), M - 1, 1) <> "0" Then
MsgBox "Duplicate entry for vehicle " & sVehicle(N) & _
" at timing " & Format(dTiming(M - 1), "hh:mm AM/PM") & _
" (cell " & grngPI.Cells(K, M).Address(False, False) & ")" & _
" of worgksheet " & .Name, _
vbApplicationModal + vbCritical + vbOKOnly, "Duplicate data"
Else
Mid(sParkTime(L, N), M - 1, 1) = "1"
End If
End If
Next M
End If
Next K
'
' unique vehicles
For K = 1 To J
grngV.Cells(K + 1, 1).Value = sVehicle(K)
For L = 1 To iColor
M = (L - 1) * (iTiming + 1) + 1
grngPO.Cells(K + 1, M).Value = ksApostrophe & sParkTime(L, K)
For N = 1 To iTiming
grngPO.Cells(K + 1, M + N).Value = Val(Mid(sParkTime(L, K), N, 1))
Next N
Next L
Next K
' formulas
' vehicles
M = grngV.Row + 1
N = J + grngV.Row
A = grngV.Offset(-1, 0).Address(, False)
A = Left(A, InStr(A, ksDollar) - 1)
grngV.Cells(0, 1).Formula = "=COUNTA(" & A & M & ":" & A & N & ")"
' parking output
M = grngPO.Row + 1
N = J + grngV.Row
For K = 1 To iColor
L = (K - 1) * (iTiming + 1)
For O = 1 To iTiming
A = rng1.Offset(-1, L + O).Address(, False)
A = Left(A, InStr(A, ksDollar) - 1)
rng1.Offset(-1, L + O).Formula = "=SUM(" & A & M & ":" & A & N & ")"
Next O
Next K
' format
Application.Union(grngV, grngPO).EntireColumn.AutoFit
Application.Union(grngV, grngPO).Borders.LineStyle = xlContinuous
Application.Union(grngV, grngPO).EntireColumn.HorizontalAlignment = xlCenter
'
' terminate
Set grngPO = Nothing
Set grngV = Nothing
Set grngPI = Nothing
Set grngT = Nothing
Set grngAR = Nothing
Set grngAT = Nothing
Set grngAC = Nothing
Set grngA = Nothing
End If
End If
End With
Next I
'
' end
Beep
'
End Sub
), how would you manually get this output.