January 1, 2010
This article is based on a sample included in a presentation that I conducted a couple of months ago. Essentially, this example pulls utilization schedules from multiple equipment resources and generates both an equipment resource specific calendar and a graphical overview of the calendars for all equipment resources. This demonstration uses ADO with a direct connection to an Oracle database for both scheduling the work orders that need to be processed at each of the equipment resources (using a very weak scheduling algorithm that does not go back to fill in unused time), and to create the graphical results in Excel.
The options area for the original Excel spreadsheet used in my presentation looked like this, but we will not create anything that complex in this article: 
-
Before starting, we need to create source data for our example (note that some of the tables created are only needed for a short period of time, and may be dropped once all of the tables are created):
First, a statistic list of parts that will be manufactured:
CREATE TABLE
T_PART_LIST AS
SELECT
CAST(DBMS_RANDOM.STRING('U',15) AS VARCHAR2(30)) PART_ID,
ROUND(DBMS_RANDOM.VALUE(1,30)) NUM_LOTS,
ROUND(DBMS_RANDOM.VALUE(1,10)) NUM_OPERATIONS
FROM
DUAL
CONNECT BY
LEVEL<=100;
Next, the operation numbers and machine resources that will be used during the manufacture of each of the parts:
CREATE TABLE
T_PART_OPERATION AS
SELECT
PL.PART_ID,
OP.RN*10 OPERATION_SEQ_NO,
CAST(ROUND(DBMS_RANDOM.VALUE(0,10),2) AS NUMBER(22,2)) RUN_HOURS,
CAST('MACHINE'||TO_CHAR(ROUND(DBMS_RANDOM.VALUE(1,100)),'000') AS VARCHAR2(15)) RESOURCE_ID
FROM
T_PART_LIST PL,
(SELECT
ROWNUM RN
FROM
DUAL
CONNECT BY
LEVEL<=10) OP
WHERE
OP.RN<=PL.NUM_OPERATIONS;
CREATE INDEX IND_T_PART_OP_PART_ID ON T_PART_OPERATION(PART_ID);
Next, the work order lots that will manufacture the parts:
CREATE TABLE
T_WORKORDER_LIST AS
SELECT
WO.WORKORDER_BASE_ID,
CAST(LN.LOT_NUM AS VARCHAR2(3)) WORKORDER_LOT_ID,
PL.PART_ID,
TRUNC(SYSDATE+ROUND(DBMS_RANDOM.VALUE(0,400))) DESIRED_WANT_DATE
FROM
(SELECT
PART_ID,
NUM_LOTS,
ROWNUM RN
FROM
T_PART_LIST) PL,
(SELECT
CAST('W'||TO_CHAR(ROWNUM+10000) AS VARCHAR2(15)) WORKORDER_BASE_ID,
ROWNUM RN
FROM
DUAL
CONNECT BY
LEVEL<=400) WO,
(SELECT
ROWNUM LOT_NUM
FROM
DUAL
CONNECT BY
LEVEL<=30) LN
WHERE
PL.RN=WO.RN
AND LN.LOT_NUM<=PL.NUM_LOTS
ORDER BY
WO.WORKORDER_BASE_ID,
LN.LOT_NUM;
Finally, a table that will eventually contain the schedules for the various machine resources:
CREATE TABLE T_RESOURCE_DAILY_SCH( RESOURCE_ID VARCHAR2(15), START_DATE DATE, FINISH_DATE DATE, RUN_HOURS NUMBER, PART_ID VARCHAR2(30), WORKORDER_BASE_ID VARCHAR2(15), WORKORDER_LOT_ID VARCHAR2(3), OPERATION_SEQ_NO NUMBER, DESIRED_WANT_DATE DATE, UNIT_ASSIGNED NUMBER); CREATE INDEX IND_T_RESOURCE_DAILY_RES ON T_RESOURCE_DAILY_SCH(RESOURCE_ID);
We now switch to Excel to build the interface area with two ActiveX command buttons:
First, name the first worksheet as ShopCalendar – this name is very important since it is referenced in the code for this example. Next, add two ActiveX command buttons in the first two rows. Give the first one the name cmdCreateSchedule, and the second one the name cmdDrawCalendar – the names are not overly critical, but the names are referenced in the code. Finally, double-click one of the buttons to access the Code Editor.
Delete any code that is shown in the Code Editor and add the following code:
Option Explicit
Dim dbDatabase As New ADODB.Connection
Dim strDatabase As String
Dim strUserName As String
Dim strPassword As String
Private Function ConnectDatabase() As Integer
Dim intResult As Integer
On Error Resume Next
If dbDatabase.State <> 1 Then
'Connection to the database if closed
strDatabase = "MyDB"
strUserName = "MyUser"
strPassword = "MyPassword"
'Connect to the database
'Oracle connection string
dbDatabase.ConnectionString = "Provider=OraOLEDB.Oracle;Data Source=" & strDatabase & ";User ID=" & strUserName & ";Password=" & strPassword & ";ChunkSize=1000;FetchSize=100;"
dbDatabase.ConnectionTimeout = 40
dbDatabase.CursorLocation = adUseClient
dbDatabase.Open
If (dbDatabase.State <> 1) Or (Err <> 0) Then
intResult = MsgBox("Could not connect to the database. Check your user name and password." & vbCrLf & Error(Err), 16, "Excel Demo")
ConnectDatabase = False
Else
ConnectDatabase = True
End If
Else
ConnectDatabase = True
End If
End Function
The above code is the basic logic needed to permit connecting to the Oracle database. Next, add a reference to the ActiveX Data Objects. Now we need to add the code for the scheduling routine – this code uses bind variables to minimize the number of hard parses:
Private Sub cmdCreateSchedule_Click()
Dim intResult As Integer
Dim strSQL As String
Dim i As Integer
Dim intResourceIndex As Integer 'Index that indicates the current resource ID index
Dim strResourceID(100) As String 'Keep track of the new resource IDs read in
Dim varResourceLastDate(100) As Date 'Keep track of the last date for the resource
Dim strWorkOrderLast As String 'Used to make certain that the next operation starts after the previous
Dim varWorkOrderLastDate As Date 'Used to make certain that the next operation starts after the previous
Dim varScheduleStart As Date 'The first date in the schedule
Dim snpData As ADODB.Recordset
Dim comData As ADODB.Command
intResult = ConnectDatabase
If intResult = False Then
Exit Sub
End If
'Set the starting point for all resources
varScheduleStart = Now
For i = 1 To 100
strResourceID(i) = ""
varResourceLastDate(i) = varScheduleStart
Next i
Set snpData = New ADODB.Recordset
Set comData = New ADODB.Command
'Retrieve the list of work order operations to be scheduled
strSQL = "SELECT" & vbCrLf
strSQL = strSQL & " WO.WORKORDER_BASE_ID," & vbCrLf
strSQL = strSQL & " WO.WORKORDER_LOT_ID," & vbCrLf
strSQL = strSQL & " WO.PART_ID," & vbCrLf
strSQL = strSQL & " WO.DESIRED_WANT_DATE," & vbCrLf
strSQL = strSQL & " PO.OPERATION_SEQ_NO," & vbCrLf
strSQL = strSQL & " PO.RUN_HOURS," & vbCrLf
strSQL = strSQL & " PO.RESOURCE_ID" & vbCrLf
strSQL = strSQL & "FROM" & vbCrLf
strSQL = strSQL & " T_WORKORDER_LIST WO," & vbCrLf
strSQL = strSQL & " T_PART_OPERATION PO" & vbCrLf
strSQL = strSQL & "WHERE" & vbCrLf
strSQL = strSQL & " WO.PART_ID=PO.PART_ID" & vbCrLf
strSQL = strSQL & "ORDER BY" & vbCrLf
strSQL = strSQL & " WO.DESIRED_WANT_DATE," & vbCrLf
strSQL = strSQL & " WO.PART_ID," & vbCrLf
strSQL = strSQL & " WO.WORKORDER_BASE_ID," & vbCrLf
strSQL = strSQL & " WO.WORKORDER_LOT_ID," & vbCrLf
strSQL = strSQL & " PO.OPERATION_SEQ_NO"
snpData.Open strSQL, dbDatabase
If snpData.State = 1 Then
'Remove the previous run
dbDatabase.Execute "TRUNCATE TABLE T_RESOURCE_DAILY_SCH"
'Set up the ADO command object to use bind variables
With comData
strSQL = "INSERT INTO T_RESOURCE_DAILY_SCH (" & vbCrLf
strSQL = strSQL & " RESOURCE_ID," & vbCrLf
strSQL = strSQL & " START_DATE," & vbCrLf
strSQL = strSQL & " FINISH_DATE," & vbCrLf
strSQL = strSQL & " RUN_HOURS," & vbCrLf
strSQL = strSQL & " PART_ID," & vbCrLf
strSQL = strSQL & " WORKORDER_BASE_ID," & vbCrLf
strSQL = strSQL & " WORKORDER_LOT_ID," & vbCrLf
strSQL = strSQL & " OPERATION_SEQ_NO," & vbCrLf
strSQL = strSQL & " DESIRED_WANT_DATE," & vbCrLf
strSQL = strSQL & " UNIT_ASSIGNED)" & vbCrLf
strSQL = strSQL & "VALUES (" & vbCrLf
strSQL = strSQL & " ?," & vbCrLf
strSQL = strSQL & " ?," & vbCrLf
strSQL = strSQL & " ?," & vbCrLf
strSQL = strSQL & " ?," & vbCrLf
strSQL = strSQL & " ?," & vbCrLf
strSQL = strSQL & " ?," & vbCrLf
strSQL = strSQL & " ?," & vbCrLf
strSQL = strSQL & " ?," & vbCrLf
strSQL = strSQL & " ?," & vbCrLf
strSQL = strSQL & " ?)"
.Parameters.Append .CreateParameter("resource_id", adVarChar, adParamInput, 15, "")
.Parameters.Append .CreateParameter("start_date", adDate, adParamInput, 8, Null)
.Parameters.Append .CreateParameter("finish_date", adDate, adParamInput, 8, Null)
.Parameters.Append .CreateParameter("run_hours", adNumeric, adParamInput, 12, 0)
.Parameters.Append .CreateParameter("part_id", adVarChar, adParamInput, 30, "")
.Parameters.Append .CreateParameter("workorder_base_id", adVarChar, adParamInput, 15, "")
.Parameters.Append .CreateParameter("workorder_lot_id", adVarChar, adParamInput, 3, "")
.Parameters.Append .CreateParameter("operation_seq_no", adNumeric, adParamInput, 12, 10)
.Parameters.Append .CreateParameter("desired_want_date", adDate, adParamInput, 8, Null)
.Parameters.Append .CreateParameter("unit_assigned", adNumeric, adParamInput, 12, 10)
.CommandText = strSQL
.CommandType = adCmdText
.CommandTimeout = 30
.ActiveConnection = dbDatabase
End With
dbDatabase.BeginTrans
Do While Not snpData.EOF
'Find the last operation date for this resource
intResourceIndex = 0
For i = 1 To 100
If strResourceID(i) = snpData("resource_id") Then
intResourceIndex = i
Exit For
End If
If strResourceID(i) = "" Then
'No match found, create a new one
intResourceIndex = i
strResourceID(i) = snpData("resource_id")
Exit For
End If
Next i
If strWorkOrderLast <> snpData("workorder_base_id") & "//" & snpData("workorder_lot_id") Then
varWorkOrderLastDate = varScheduleStart
End If
If varResourceLastDate(intResourceIndex) >= varWorkOrderLastDate Then
comData("start_date") = varResourceLastDate(intResourceIndex)
Else
comData("start_date") = varWorkOrderLastDate
End If
If varResourceLastDate(intResourceIndex) >= varWorkOrderLastDate Then
comData("finish_date") = DateAdd("n", snpData("run_hours") * 60, varResourceLastDate(intResourceIndex))
varWorkOrderLastDate = DateAdd("n", snpData("run_hours") * 60, varResourceLastDate(intResourceIndex))
Else
comData("finish_date") = DateAdd("n", snpData("run_hours") * 60, varWorkOrderLastDate)
varWorkOrderLastDate = DateAdd("n", snpData("run_hours") * 60, varWorkOrderLastDate)
End If
varResourceLastDate(intResourceIndex) = varWorkOrderLastDate
strWorkOrderLast = snpData("workorder_base_id") & "//" & snpData("workorder_lot_id")
comData("resource_id") = snpData("resource_id")
comData("run_hours") = snpData("run_hours")
comData("part_id") = snpData("part_id")
comData("workorder_base_id") = snpData("workorder_base_id")
comData("workorder_lot_id") = snpData("workorder_lot_id")
comData("operation_seq_no") = snpData("operation_seq_no")
comData("desired_want_date") = snpData("desired_want_date")
comData("unit_assigned") = 1
'Execute the insert statement with bind variables
comData.Execute
snpData.MoveNext
Loop
snpData.Close
'Issue a COMMIT
dbDatabase.CommitTrans
Else
intResult = MsgBox("Could not query the database." & vbCrLf & Error(Err), 16, "Excel Demo")
End If
Set snpData = Nothing
Set comData = Nothing
End Sub
Switch back to the Excel window and turn off Design Mode. Clicking the Create Schedule button should populate the T_RESOURCE_DAILY_SCH table. Once that code finishes executing, switch back to the Code Editor and add the following below the rest of the code:
Private Sub cmdDrawCalendar_Click()
Dim i As Long
Dim j As Integer
Dim intFlag As Integer
Dim intBaseRow As Integer
Dim intBaseRowMax As Integer
Dim intDataRow As Integer
Dim intWeek As Integer
Dim intResult As Integer
Dim intWeekDay As Integer
Dim intGraphicalMovable As Integer 'Determines if a graphical view will be created
Dim intGraphicalFixed As Integer 'Determines if a graphical metafile will be created
Dim strSQL As String
Dim strLastResourceID As String
Dim strLine As String
Dim varWeekStart(1000) As Date
Dim varWeekEnd(1000) As Date
Dim lngBoxHeight As Long
Dim lngBoxLengthMult As Single
Dim lngFontSize As Long
Dim lngBoxTop As Long
Dim lngBoxLeft As Long
Dim lngBoxWidth As Long
Dim lngMaxCapacity As Long
Dim varBaseDate As Date
Dim lngResourceTop As Long 'Current top position for the resource ID
Dim strFilename As String
Dim snpData As ADODB.Recordset
Dim comData As ADODB.Command
'Don't break the code if an error is returned
On Error Resume Next
intGraphicalMovable = True
intGraphicalFixed = False
intResult = ConnectDatabase
If intResult = False Then
intResult = MsgBox("Could not connect to the Visual database. Check your user name and password." & vbCrLf & Error(Err), 16, "Excel Demo")
Exit Sub
End If
If intGraphicalFixed = True Then
'See if we need to delete the worksheet from a previous execution
For i = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i).Name = "ShopCalendarViewFixed" Then
Sheets("ShopCalendarViewFixed").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Exit For
End If
Next i
'Add a new worksheet to the workbook after the ShopCalendar worksheet
ActiveWorkbook.Sheets.Add , Sheets("ShopCalendar")
ActiveWorkbook.ActiveSheet.Name = "ShopCalendarViewFixed"
End If
If intGraphicalMovable = True Then
'See if we need to delete the worksheet from a previous execution
For i = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i).Name = "ShopCalendarView" Then
Sheets("ShopCalendarView").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Exit For
End If
Next i
'Add a new worksheet to the workbook after the ShopCalendar worksheet
ActiveWorkbook.Sheets.Add , Sheets("ShopCalendar")
ActiveWorkbook.ActiveSheet.Name = "ShopCalendarView"
End If
Sheets("ShopCalendar").Select
Set snpData = New ADODB.Recordset
Set comData = New ADODB.Command
Sheets("ShopCalendar").Rows("13:10000").Delete Shift:=xlUp
With comData
strSQL = "SELECT" & vbCrLf
strSQL = strSQL & " RESOURCE_ID," & vbCrLf
strSQL = strSQL & " START_DATE," & vbCrLf
strSQL = strSQL & " FINISH_DATE," & vbCrLf
strSQL = strSQL & " RUN_HOURS," & vbCrLf
strSQL = strSQL & " PART_ID," & vbCrLf
strSQL = strSQL & " WORKORDER_BASE_ID," & vbCrLf
strSQL = strSQL & " WORKORDER_LOT_ID," & vbCrLf
strSQL = strSQL & " OPERATION_SEQ_NO," & vbCrLf
strSQL = strSQL & " DESIRED_WANT_DATE," & vbCrLf
strSQL = strSQL & " UNIT_ASSIGNED" & vbCrLf
strSQL = strSQL & "FROM" & vbCrLf
strSQL = strSQL & " T_RESOURCE_DAILY_SCH" & vbCrLf
strSQL = strSQL & "WHERE" & vbCrLf
strSQL = strSQL & " START_DATE<=TRUNC(SYSDATE+45)" & vbCrLf
strSQL = strSQL & "ORDER BY" & vbCrLf
strSQL = strSQL & " RESOURCE_ID," & vbCrLf
strSQL = strSQL & " START_DATE," & vbCrLf
strSQL = strSQL & " FINISH_DATE," & vbCrLf
strSQL = strSQL & " WORKORDER_BASE_ID," & vbCrLf
strSQL = strSQL & " WORKORDER_LOT_ID"
'Set up the command properties
.CommandText = strSQL
.CommandType = adCmdText
.CommandTimeout = 30
.ActiveConnection = dbDatabase
End With
Set snpData = comData.Execute
varBaseDate = Date
lngBoxLengthMult = 0.1
lngBoxHeight = 8
lngResourceTop = 30
lngFontSize = 6
varBaseDate = Date
If Not (snpData Is Nothing) Then
'If snpData.State = 1 Then
Application.ScreenUpdating = False
If intGraphicalMovable = True Then
For i = 0 To 30
lngBoxLeft = 70 + lngBoxLengthMult * (i * 60 * 24)
lngBoxWidth = lngBoxLengthMult * (60 * 24) - 1
With Sheets("ShopCalendarView").Shapes.AddTextbox(msoTextOrientationHorizontal, lngBoxLeft, lngBoxTop, lngBoxWidth, (lngBoxHeight * 2 - 1))
With .TextFrame
.Characters.Text = Format(DateAdd("d", i, varBaseDate), "m/d")
.Characters.Font.Size = (lngBoxHeight - 2) * 2
End With
.Fill.ForeColor.RGB = RGB(255 - 4 * (Weekday(DateAdd("d", i, varBaseDate), vbMonday) - 1), 255 - 4 * (Weekday(DateAdd("d", i, varBaseDate), vbMonday) - 1), 255 - 4 * (Weekday(DateAdd("d", i, varBaseDate), vbMonday) - 1))
End With
Next i
End If
If Not (snpData.EOF) Then
intBaseRowMax = 10
'Find the week start and end dates of each week
varWeekStart(1) = CDate(Format(DateAdd("d", -Weekday(snpData("start_date"), vbMonday) + 1, snpData("start_date")), "mm/dd/yyyy"))
varWeekEnd(1) = DateAdd("d", 6, varWeekStart(1))
For i = 2 To 1000
varWeekStart(i) = DateAdd("d", (i - 1) * 7, varWeekStart(1))
varWeekEnd(i) = DateAdd("d", 6, varWeekStart(i))
Next i
Do While Not snpData.EOF
If strLastResourceID <> snpData("resource_id") Then
'Started a new resource ID
If intBaseRow > 10 Then
'Write out the week start dates for the last resource, and draw the borders
For i = intBaseRow To intBaseRowMax - 1
Sheets("ShopCalendar").Cells(i + 1, 1).Value = Format(varWeekStart(i - intBaseRow + 1), "mm/dd/yyyy")
Next i
Sheets("ShopCalendar").Range("B" & Format(intBaseRow) & ":H" & Format(intBaseRowMax)).Select
With Selection.Borders(xlEdgeLeft)
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.Weight = xlThin
End With
End If
If intGraphicalMovable = True Then
'For the graphical view
lngResourceTop = lngResourceTop + lngMaxCapacity * (lngBoxHeight) + 10
lngBoxLeft = 1
lngBoxWidth = 40
lngBoxTop = lngResourceTop
With Sheets("ShopCalendarView").Shapes.AddTextbox(msoTextOrientationHorizontal, lngBoxLeft, lngBoxTop, lngBoxWidth, (lngBoxHeight - 1))
With .TextFrame
'.AutoMargins = False
.Characters.Text = snpData("resource_id")
.Characters.Font.Size = lngBoxHeight - 2
.MarginLeft = 0
.MarginRight = 0
.MarginTop = 0
.MarginBottom = 0
End With
.Fill.ForeColor.RGB = RGB(255, 255, 255)
End With
End If
lngMaxCapacity = 0
intBaseRow = intBaseRowMax + 4
strLastResourceID = snpData("resource_id")
Sheets("ShopCalendar").Cells(intBaseRow - 1, 1).Value = snpData("resource_id")
Sheets("ShopCalendar").Cells(intBaseRow - 1, 1).Font.Bold = True
Sheets("ShopCalendar").Cells(intBaseRow - 1, 1).Font.Size = 14
For i = 1 To 7
Sheets("ShopCalendar").Cells(intBaseRow, i + 1).Value = Format(DateAdd("d", i - 1, varWeekStart(1)), "DDD")
Sheets("ShopCalendar").Cells(intBaseRow, i + 1).Font.Bold = True
Next i
End If
If Not IsNull(snpData("unit_assigned")) Then
If lngMaxCapacity < snpData("unit_assigned") Then
'Need to update the maximum unit assigned value
lngMaxCapacity = snpData("unit_assigned")
End If
If (varBaseDate < snpData("start_date")) Or (varBaseDate < snpData("finish_date")) Then
If lngMaxCapacity < snpData("unit_assigned") Then
lngMaxCapacity = snpData("unit_assigned")
End If
If intGraphicalMovable = True Then
lngBoxLeft = 70 + lngBoxLengthMult * (DateDiff("n", varBaseDate, snpData("start_date")))
lngBoxWidth = lngBoxLengthMult * ((DateDiff("n", varBaseDate, snpData("finish_date")) - DateDiff("n", varBaseDate, snpData("start_date"))))
lngBoxTop = lngResourceTop + snpData("unit_assigned") * lngBoxHeight
With Sheets("ShopCalendarView").Shapes.AddTextbox(msoTextOrientationHorizontal, lngBoxLeft, lngBoxTop, lngBoxWidth, (lngBoxHeight - 1))
With .TextFrame
'.AutoMargins = False
.Characters.Text = snpData("workorder_base_id") & "/" & snpData("workorder_lot_id") & " OP " & CStr(snpData("operation_seq_no"))
.Characters.Font.Size = lngBoxHeight - 2
.MarginLeft = 0
.MarginRight = 0
.MarginTop = 0
.MarginBottom = 0
End With
If snpData("finish_date") > snpData("desired_want_date") Then
.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
.Fill.ForeColor.RGB = RGB(0, 255, 255)
End If
' If snpData("workorder_sub_id") = "0" Then
.AlternativeText = "WO:" & snpData("workorder_base_id") & "/" & snpData("workorder_lot_id") & " OP:" & CStr(snpData("operation_seq_no")) & Chr(10) & "Part ID:" & snpData("part_id") & Chr(10) & Format(snpData("start_date"), "mm/dd/yyyy hh:nn") & " - " & Format(snpData("finish_date"), "mm/dd/yyyy hh:nn") & Chr(10) & snpData("resource_id")
' Else
' .AlternativeText = "WO:" & snpData("workorder_base_id") & "-" & snpData("workorder_sub_id") & "/" & snpData("workorder_lot_id") & " OP:" & CStr(snpData("sequence_no")) & Chr(10) & "Part ID:" & snpData("part_id") & Chr(10) & Format(snpData("start_date"), "mm/dd hh:nn") & " - " & Format(snpData("finish_date"), "mm/dd hh:nn") & Chr(10) & snpData("resource_id")
' End If
End With
End If
End If
End If
For i = 0 To DateDiff("d", CDate(Format(snpData("start_date"), "mm/dd/yyyy")), CDate(Format(snpData("finish_date"), "mm/dd/yyyy")))
intWeekDay = Weekday(DateAdd("d", i, snpData("start_date")), vbMonday) 'Column
'Find the row to place the information into
For j = 1 To 1000
If varWeekEnd(j) >= CDate(Format(DateAdd("d", i, snpData("start_date")), "mm/dd/yyyy")) Then
'Found the week for this record
intDataRow = intBaseRow + j
If intDataRow > intBaseRowMax Then
intBaseRowMax = intDataRow
End If
Exit For
End If
Next j
If (i = 0) And (i = DateDiff("d", CDate(Format(snpData("start_date"), "mm/dd/yyyy")), CDate(Format(snpData("finish_date"), "mm/dd/yyyy")))) Then
'Need to include the start time and the end time
strLine = Format(snpData("start_date"), "hh:nn") & " - " & Format(snpData("finish_date"), "hh:nn") & " " & snpData("part_id")
Else
If i = 0 Then
'Need to include the start time
strLine = Format(snpData("start_date"), "hh:nn") & " - C0:00" & " " & snpData("part_id")
Else
If i = DateDiff("d", CDate(Format(snpData("start_date"), "mm/dd/yyyy")), CDate(Format(snpData("finish_date"), "mm/dd/yyyy"))) Then
'Need to include the end time
strLine = "C0:00" & " - " & Format(snpData("finish_date"), "hh:nn") & " " & snpData("part_id")
Else
'Operation is continuing through this date
strLine = "C0:00" & " - C0:00" & " " & snpData("part_id")
End If
End If
End If
strLine = strLine & " " & snpData("workorder_base_id")
' If snpData("workorder_sub_id") <> "0" Then
' strLine = strLine & "-" & snpData("workorder_sub_id")
' End If
strLine = strLine & "/" & snpData("workorder_lot_id")
strLine = strLine & " OP " & Format(snpData("operation_seq_no"))
If Sheets("ShopCalendar").Cells(intDataRow, intWeekDay + 1).Value = "" Then
'Writing into a new cell
Sheets("ShopCalendar").Cells(intDataRow, intWeekDay + 1).Value = strLine
Else
'Writing into a cell already containing data
Sheets("ShopCalendar").Cells(intDataRow, intWeekDay + 1).Value = Sheets("ShopCalendar").Cells(intDataRow, intWeekDay + 1).Value & Chr(10) & strLine
End If
Next i
snpData.MoveNext
Loop
If intBaseRow > 10 Then
'Write out the week start dates for the last resource
For i = intBaseRow To intBaseRowMax - 1
Sheets("ShopCalendar").Cells(i + 1, 1).Value = Format(varWeekStart(i - intBaseRow + 1), "mm/dd/yyyy")
Next i
Sheets("ShopCalendar").Range("B" & Format(intBaseRow) & ":H" & Format(intBaseRowMax)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.Weight = xlThick
End With
With Selection.Borders(xlEdgeTop)
.Weight = xlThick
End With
With Selection.Borders(xlEdgeBottom)
.Weight = xlThick
End With
With Selection.Borders(xlEdgeRight)
.Weight = xlThick
End With
With Selection.Borders(xlInsideVertical)
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.Weight = xlThin
End With
End If
End If
snpData.Close
End If
Sheets("ShopCalendar").Rows("10:" & Format(intBaseRowMax)).VerticalAlignment = xlTop
Sheets("ShopCalendar").PageSetup.PrintArea = "$A$13:$H$" & Format(intBaseRowMax)
With Sheets("ShopCalendar").PageSetup
.CenterFooter = "Generated " & Format(Now, "mm/dd/yyyy hh:nn")
.RightFooter = "Page &P of &N"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintGridlines = False
.Orientation = xlLandscape
'.PaperSize = xlPaperLetter
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 300
End With
Sheets("ShopCalendar").Range("B2").Select
ActiveWindow.FreezePanes = True
Sheets("ShopCalendar").Columns("B:H").Select
Selection.ColumnWidth = 44
Selection.WrapText = True
Sheets("ShopCalendar").Columns("A:A").ColumnWidth = 10.43
Sheets("ShopCalendar").Range("A13").Select
Application.ScreenUpdating = True
Set snpData = Nothing
Set comData = Nothing
End Sub
With the above code added, the Draw Calendar button should now work. Click the Draw Calendar button, the output should look something like what you see below:
A second tab is added to the worksheet that shows a graphical overview, with cyan colored bars representing operations that will complete before the work order due date and red colored bars representing operations that will complete after the work order due date:
I may post a follow-up at some point that shows how to generate an enhanced Windows metafile (EMF) which shows the graphical view of the resource utilization.
Recent Comments