Sub GenerateAuditSchedule()
Dim wsSrc As Worksheet, wsDst As Worksheet, wsProcessInfo As Worksheet
Dim lastRow As Long, lastCol As Long
Dim auditDate As Date, sessionID As Integer
Dim srcRange As Range, cell As Range
Dim dstRow As Long, dstCol As Integer
Dim headerRow As Range, workcellHeaders As Variant
Dim dict As Object
Dim timeSplit As Variant
Dim dateList As String
Dim i As Integer
Dim sessionDetails As Collection
Dim sessionArray() As Variant
Dim tempSession As Variant
Dim j As Long, k As Long
Dim processLookup As Object
Dim processName As String
Dim processData As Variant
' Set source and destination worksheets
Set wsSrc = ActiveSheet ' Source data is in the current sheet
On Error Resume Next
Set wsDst = Worksheets("Audit Plan")
Set wsProcessInfo = Worksheets("Process Information") ' Process Information
sheet
If wsDst Is Nothing Then
MsgBox "Audit Plan sheet not found!", vbExclamation
Exit Sub
End If
If wsProcessInfo Is Nothing Then
MsgBox "Process Information sheet not found!", vbExclamation
Exit Sub
End If
On Error GoTo 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
' Clear old content but keep headers
wsDst.Rows("4:" & wsDst.Rows.Count).Delete Shift:=xlUp
' Find last row and column in source sheet
lastRow = wsSrc.Cells(wsSrc.Rows.Count, 2).End(xlUp).Row
lastCol = wsSrc.Cells(3, wsSrc.Columns.Count).End(xlToLeft).Column
' Extract workcell headers dynamically
Set headerRow = wsSrc.Range(wsSrc.Cells(3, 3), wsSrc.Cells(3, lastCol - 1))
workcellHeaders = headerRow.Value
' Dictionary to track unique audit dates
Set dict = CreateObject("Scripting.Dictionary")
' Identify unique audit dates
For Each cell In wsSrc.Range(wsSrc.Cells(4, 3), wsSrc.Cells(lastRow, lastCol -
1))
If cell.Value <> "" Then
timeSplit = Split(cell.Value, vbLf)
If UBound(timeSplit) = 1 Then
auditDate = CDate(timeSplit(0))
If Not dict.exists(auditDate) Then dict.Add auditDate, Nothing
End If
End If
Next cell
' Sort dates
Dim auditDates() As Variant
auditDates = dict.keys
If dict.Count > 1 Then
QuickSort auditDates, LBound(auditDates), UBound(auditDates)
End If
' Generate list of audit dates
dateList = "Audit Dates Found:" & vbNewLine & String(30, "-") & vbNewLine
For i = LBound(auditDates) To UBound(auditDates)
dateList = dateList & Format(auditDates(i), "mmmm dd, yyyy") & vbNewLine
Next i
' Display audit dates before proceeding
' MsgBox dateList, vbInformation, "Audit Dates Overview"
' Set up Process Name lookup dictionary
Set processLookup = CreateObject("Scripting.Dictionary")
' Load process information into the dictionary
For i = 2 To wsProcessInfo.Cells(wsProcessInfo.Rows.Count, 1).End(xlUp).Row
processName = wsProcessInfo.Cells(i, 1).Value
processData = Array(wsProcessInfo.Cells(i, 2).Value, wsProcessInfo.Cells(i,
3).Value, wsProcessInfo.Cells(i, 4).Value)
processLookup.Add processName, processData
Next i
' Start writing to Audit Plan
dstRow = 4
sessionID = 1
' Loop through audit dates
For i = LBound(auditDates) To UBound(auditDates)
auditDate = auditDates(i)
' Write headers for the date
wsDst.Cells(dstRow, 1).Value = "Session"
wsDst.Cells(dstRow, 2).Value = auditDate
wsDst.Cells(dstRow, 3).Value = "Jabil Business / Ops Process"
wsDst.Cells(dstRow, 4).Resize(1, 3).Merge: wsDst.Cells(dstRow, 4).Value =
"Process / Activity" & vbCrLf & " Include CARs, CSPAs, and Audit Findings that
require review"
wsDst.Cells(dstRow, 7).Value = "Customer/ Site"
wsDst.Cells(dstRow, 8).Value = "Standard Clause(s)"
wsDst.Cells(dstRow, 9).Value = "Assessment Team"
wsDst.Cells(dstRow, 10).Value = "Auditee(s)"
wsDst.Cells(dstRow, 11).Value = "Audit Location"
wsDst.Cells(dstRow, 12).Value = "Supporting info to consider"
wsDst.Cells(dstRow, 13).Value = "Status"
' Formatting
With wsDst.Range(wsDst.Cells(dstRow, 1), wsDst.Cells(dstRow, 13))
.Font.Bold = True
.Interior.Color = RGB(197, 217, 241)
.Borders.LineStyle = xlContinuous
.WrapText = True
End With
dstRow = dstRow + 1
' Opening Meeting
If i = LBound(auditDates) Then
wsDst.Cells(dstRow, 1).Value = 0
wsDst.Cells(dstRow, 3).Resize(1, 6).Merge: wsDst.Cells(dstRow, 3).Value
= "OPENING MEETING"
wsDst.Cells(dstRow, 10).Value = "FMs, WCMs, BUMs"
wsDst.Cells(dstRow, 12).Value = "Site Attendees: Site Ops Manager,
Management Representative, Functional Managers"
ApplyBordersAndWrapText wsDst.Range(wsDst.Cells(dstRow, 1),
wsDst.Cells(dstRow, 13)) ' Apply borders and wrap text
wsDst.Range(wsDst.Cells(dstRow, 1), wsDst.Cells(dstRow,
13)).Interior.Color = RGB(230, 184, 183)
wsDst.Range(wsDst.Cells(dstRow, 3), wsDst.Cells(dstRow, 3)).Font.Bold =
True
wsDst.Range(wsDst.Cells(dstRow, 3), wsDst.Cells(dstRow, 3)).Font.Size =
16
dstRow = dstRow + 1
End If
' Initialize session collection
Set sessionDetails = New Collection
' Loop through source data to extract sessions for the current audit date
For Each cell In wsSrc.Range(wsSrc.Cells(4, 3), wsSrc.Cells(lastRow,
lastCol - 1))
If cell.Value <> "" Then
timeSplit = Split(cell.Value, vbLf)
If UBound(timeSplit) = 1 Then
If CDate(timeSplit(0)) = auditDate Then
' Collect session details (start time, process name,
workcell, auditor)
sessionDetails.Add Array((timeSplit(1)),
wsSrc.Cells(cell.Row, 2).Value, wsSrc.Cells(3, cell.Column).Value,
wsSrc.Cells(cell.Row, lastCol).Value)
End If
End If
End If
Next cell
' Convert collection to array for sorting by start time
ReDim sessionArray(sessionDetails.Count - 1)
For j = 1 To sessionDetails.Count
sessionArray(j - 1) = sessionDetails(j)
Next j
' Sort the sessions by start time (index 0 of the session array)
For j = LBound(sessionArray) To UBound(sessionArray) - 1
For k = j + 1 To UBound(sessionArray)
' Compare start times (sessionArray(j)(0) vs sessionArray(k)(0))
timej = CDate(Left(sessionArray(j)(0), InStr(sessionArray(j)(0),
"-") - 1))
timek = CDate(Left(sessionArray(k)(0), InStr(sessionArray(k)(0),
"-") - 1))
If timej > timek Then
' Swap the sessions based on start time
tempSession = sessionArray(j)
sessionArray(j) = sessionArray(k)
sessionArray(k) = tempSession
End If
Next k
Next j
' Write sorted sessions to the Audit Plan
lunchcheck = True
For j = LBound(sessionArray) To UBound(sessionArray)
timej = CDate(Left(sessionArray(j)(0), InStr(sessionArray(j)(0), "-") -
1))
noon = CDate("12:30")
timecheck = timej > noon
If lunchcheck And timecheck Then
' Lunch Break
wsDst.Cells(dstRow, 1).Value = 0
wsDst.Cells(dstRow, 3).Resize(1, 10).Merge: wsDst.Cells(dstRow,
3).Value = "Lunch"
wsDst.Cells(dstRow, 2).Value = "12:00-13:00"
ApplyBordersAndWrapText wsDst.Range(wsDst.Cells(dstRow, 1),
wsDst.Cells(dstRow, 13)) ' Apply borders and wrap text
wsDst.Range(wsDst.Cells(dstRow, 1), wsDst.Cells(dstRow,
13)).Interior.Color = RGB(255, 255, 255)
wsDst.Range(wsDst.Cells(dstRow, 3), wsDst.Cells(dstRow,
3)).Font.Bold = True
dstRow = dstRow + 1
lunchcheck = False
End If
' Process Lookup for missing info
processName = sessionArray(j)(1) ' Process Name
If processLookup.exists(processName) Then
processData = processLookup(processName)
wsDst.Cells(dstRow, 4).Resize(1, 3).Merge: wsDst.Cells(dstRow,
4).Value = processData(0) ' Process/Activity
wsDst.Cells(dstRow, 8).Value = processData(1) ' Standard Clause(s)
wsDst.Cells(dstRow, 12).Value = processData(2) ' Supporting info to
consider
End If
wsDst.Cells(dstRow, 1).Value = sessionID ' Session ID
sessionID = sessionID + 1
wsDst.Cells(dstRow, 2).Value = sessionArray(j)(0) ' Start Time
wsDst.Cells(dstRow, 3).Value = sessionArray(j)(1) ' Process Name
wsDst.Cells(dstRow, 7).Value = sessionArray(j)(2) ' Workcell
wsDst.Cells(dstRow, 9).Value = sessionArray(j)(3) ' Auditor
wsDst.Cells(dstRow, 13).Value = "Open" ' Status
ApplyBordersAndWrapText wsDst.Range(wsDst.Cells(dstRow, 1),
wsDst.Cells(dstRow, 13)) ' Apply borders and wrap text
dstRow = dstRow + 1
Next j
' Daily Wrap-up
wsDst.Cells(dstRow, 1).Value = 0
wsDst.Cells(dstRow, 3).Resize(1, 10).Merge: wsDst.Cells(dstRow, 3).Value =
"Daily Wrap-up"
ApplyBordersAndWrapText wsDst.Range(wsDst.Cells(dstRow, 1),
wsDst.Cells(dstRow, 13)) ' Apply borders and wrap text
wsDst.Range(wsDst.Cells(dstRow, 1), wsDst.Cells(dstRow, 13)).Interior.Color
= RGB(255, 255, 255)
wsDst.Range(wsDst.Cells(dstRow, 3), wsDst.Cells(dstRow, 3)).Font.Bold =
True
dstRow = dstRow + 1
Next i
' Closing Meeting
wsDst.Cells(dstRow, 1).Value = 0
wsDst.Cells(dstRow, 3).Resize(1, 6).Merge: wsDst.Cells(dstRow, 3).Value =
"CLOSING MEETING"
wsDst.Cells(dstRow, 10).Value = "FMs, WCMs, BUMs"
wsDst.Cells(dstRow, 12).Value = "Site Attendees: Site Ops Manager, Management
Representative, Functional Managers"
ApplyBordersAndWrapText wsDst.Range(wsDst.Cells(dstRow, 1), wsDst.Cells(dstRow,
13)) ' Apply borders and wrap text
wsDst.Range(wsDst.Cells(dstRow, 1), wsDst.Cells(dstRow, 13)).Interior.Color =
RGB(230, 184, 183)
wsDst.Range(wsDst.Cells(dstRow, 3), wsDst.Cells(dstRow, 3)).Font.Bold = True
wsDst.Range(wsDst.Cells(dstRow, 3), wsDst.Cells(dstRow, 3)).Font.Size = 16
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Audit schedule generated successfully!", vbInformation
End Sub
' Apply borders and wrap text to a range
Sub ApplyBordersAndWrapText(rng As Range)
With rng
.Borders.LineStyle = xlContinuous
.WrapText = True
.Interior.Color = RGB(218, 238, 243)
End With
End Sub
' QuickSort for sorting dates
Sub QuickSort(arr As Variant, ByVal first As Long, ByVal last As Long)
Dim i As Long, j As Long, pivot As Variant, temp As Variant
i = first: j = last
pivot = arr((first + last) \ 2)
Do While i <= j
Do While arr(i) < pivot: i = i + 1: Loop
Do While arr(j) > pivot: j = j - 1: Loop
If i <= j Then
temp = arr(i): arr(i) = arr(j): arr(j) = temp
i = i + 1: j = j - 1
End If
Loop
If first < j Then QuickSort arr, first, j
If i < last Then QuickSort arr, i, last
End Sub
