This page discusses how to create the project plan and actual data table based on the Primavera P6 Xer file using Excel VBA and SQL. It is presumed that the project Xer file has been made available and parsed to every distinct data table. How to read and parse the xer file is discussed on the page Xer (P6 text file) written to Excel.
The data to be covered by the project data table are viewed on the Userform for reference.
Sub PRAP_DataBase() Set wba = Workbooks("PRAP.xlam"): Set wsa = wba.Worksheets("xer") Set wb = ActiveWorkbook: Set ws = wb.ActiveSheet If wsa.Cells(1, 1) <> "" Then Filename = wsa.Cells(1, 1).Value Else Call Choose_XerFile End If Dateformat = DateformatProcedure Call ImportXer 'run import and create data tables If wsa.Cells(2, 1) <> "" Then ProjectID = wsa.Cells(2, 1).Value ProjectName = wsa.Cells(2, 2).Value Else MsgBox "A project to work with is required. Select an Icon ""Project Summary"" on the Ribbon." Exit Sub End If With uf_PRAPDB .Label1.Caption = "Xer File: " & Filename .Label2.Caption = "Project ID: " & ProjectID .Label3.Caption = "Project Name: " & ProjectName .CommandButton1.Enabled = False With .ListBox1 .List = Array("Start", "Finish", "Actual Start", "Actual Finish", "Remain Start", "Remain Finish") End With With .ListBox2 .List = Array("Budget", "Actual", "Earned Value", "Remaining") End With With .ListBox3 .List = Array("Budget", "Actual", "Remaining") End With With .ListBox4 .List = Array("Budget", "Actual", "Remaining") End With .CommandButton1.Enabled = True .Show vbModeless End With End Sub
Private Sub CommandButton1_Click() Call WBSHierarchy Call PRPTask_list MsgBox "PRAP Source data table is generated" End Sub
Sub WBSHierarchy() 'Create myWBS data ble containing the path of hierarchical level order Dim i As Long, j As Long, K As Long, r As Long, c As Long Dim n1 As Long, n2 As Long, n3 As Long, n4 As Long, n5 As Long Dim p1 As String, p2 As String, p3 As String, p4 As String, p5 As Long Dim ws As Worksheet r = UBound(myTable(iPROJWBS)) c = UBound(myTable(iPROJWBS), 2) Dim iproj_id As Long, iwbs_id As Long, iparent_wbs_id As Long For i = 1 To c If myTable(iPROJWBS)(2, i) = "proj_id" Then iproj_id = i End If If myTable(iPROJWBS)(2, i) = "wbs_id" Then iwbs_id = i End If If myTable(iPROJWBS)(2, i) = "parent_wbs_id" Then iparent_wbs_id = i End If Next i n = 0 For i = 3 To r If myTable(iPROJWBS)(i, iproj_id) = CStr(ProjectID) Then n = n + 1 End If Next i Dim myWBSTemp() As Variant Erase myWBSTemp ReDim Preserve myWBSTemp(n + 1 + 1, c + 3) myWBSTemp(1, 1) = "myWBS" For i = 1 To c myWBSTemp(2, i) = myTable(iPROJWBS)(2, i) Next i myWBSTemp(2, c + 1) = "path" myWBSTemp(2, c + 2) = "level" myWBSTemp(2, c + 3) = "order" n = 0 For i = 3 To UBound(myTable(iPROJWBS)) If myTable(iPROJWBS)(i, 2) = CStr(ProjectID) Then n = n + 1 For j = 1 To c myWBSTemp(n + 2, j) = myTable(iPROJWBS)(i, j) Next j End If Next i For i = 3 To UBound(myWBSTemp) p1 = myWBSTemp(i, iparent_wbs_id) n1 = 0 For j = 1 To UBound(myWBSTemp) If myWBSTemp(j, iwbs_id) = CStr(p1) Then n1 = n1 + 1 If n1 = 1 Then n1 = j Exit For End If End If Next j If n1 > 0 Then p2 = myWBSTemp(n1, iparent_wbs_id) n2 = 0 For j = 1 To UBound(myWBSTemp) If myWBSTemp(j, iwbs_id) = CStr(p2) Then n2 = n2 + 1 If n2 = 1 Then n2 = j Exit For End If End If Next j End If If n2 > 0 Then p3 = myWBSTemp(n2, iparent_wbs_id) n3 = 0 For j = 1 To UBound(myWBSTemp) If myWBSTemp(j, iwbs_id) = CStr(p3) Then n3 = n3 + 1 If n3 = 1 Then n3 = j Exit For End If End If Next j End If If n3 > 0 Then p4 = myWBSTemp(n3, iparent_wbs_id) n4 = 0 For j = 1 To UBound(myWBSTemp) If myWBSTemp(j, iwbs_id) = CStr(p4) Then n4 = n4 + 1 If n4 = 1 Then n4 = j Exit For End If End If Next j End If If n4 > 0 Then p5 = myWBSTemp(n4, iparent_wbs_id) n5 = 0 For j = 1 To UBound(myWBSTemp) If myWBSTemp(j, iwbs_id) = CStr(p5) Then n5 = n5 + 1 If n5 = 1 Then n5 = j Exit For End If End If Next j End If Select Case 0 Case n1 'Level 1 activity myWBSTemp(i, c + 1) = myWBSTemp(i, iparent_wbs_id) & "|" & myWBSTemp(i, iwbs_id) myWBSTemp(i, c + 2) = 1 myWBSTemp(i, c + 3) = i Case n2 'Level 2 activity myWBSTemp(i, c + 1) = p2 & "|" & myWBSTemp(i, iparent_wbs_id) & "|" & myWBSTemp(i, iwbs_id) myWBSTemp(i, c + 2) = 2 myWBSTemp(i, c + 3) = i Case n3 'Level 3 activity myWBSTemp(i, c + 1) = p3 & "|" & p2 & "|" & myWBSTemp(i, iparent_wbs_id) & "|" _ & myWBSTemp(i, iwbs_id) myWBSTemp(i, c + 2) = 3 myWBSTemp(i, c + 3) = i Case n4 'Level 4 mactivity myWBSTemp(i, c + 1) = p4 & "|" & p3 & "|" & p2 & "|" & myWBSTemp(i, iparent_wbs_id) _ & "|" & myWBSTemp(i, iwbs_id) myWBSTemp(i, c + 2) = 4 myWBSTemp(i, c + 3) = i Case n5 'Level 5 activity myWBSTemp(i, c + 1) = p5 & "|" & p4 & "|" & p3 & "|" & p2 & "|" & myWBSTemp(i, iparent_wbs_id) _ & "|" & myWBSTemp(i, iwbs_id) myWBSTemp(i, c + 2) = 5 myWBSTemp(i, c + 3) = i End Select Dim iwbs_name As Integer, iorder As Integer, ilevel As Integer, ipath As Integer Erase myWBS ReDim Preserve myWBS(UBound(myWBSTemp), 6) For j = 1 To UBound(myWBSTemp, 2) Select Case myWBSTemp(2, j) Case "wbs_id" iwbs_id = j Case "wbs_name" iwbs_name = j Case "order" iorder = j Case "level" ilevel = j Case "path" ipath = j Case "proj_id" iproj_id = j End Select Next j ' Erase myWBSTemp ' myWBS(1, 1) = "myWBS" For j = 1 To UBound(myWBSTemp) myWBS(j, 1) = myWBSTemp(j, iwbs_id) myWBS(j, 2) = myWBSTemp(j, iwbs_name) myWBS(j, 3) = myWBSTemp(j, iorder) myWBS(j, 4) = myWBSTemp(j, ilevel) myWBS(j, 5) = myWBSTemp(j, ipath) myWBS(j, 6) = myWBSTemp(j, iproj_id) Next j Next i Erase myWBSTemp End Sub
Sub PRPTask_list() Dim strSql1 As String Dim Temp As Variant, myTemp As Variant With Application .ScreenUpdating = False .DisplayAlerts = False .StatusBar = "Please wait..." End With '******************************************************* '1. Load data worksheet '******************************************************* wshtName = myTable(iCALENDAR)(1, 1) Call AddWorksheet(wshtName, myTable(iCALENDAR)) wshtName = myWBS(1, 1) Call AddWorksheet(wshtName, myWBS) wshtName = myTable(iTask)(1, 1) Call AddWorksheet(wshtName, myTable(iTask)) wshtName = myTable(iPROJECT)(1, 1) Call AddWorksheet(wshtName, myTable(iPROJECT)) wshtName = myTable(iTASKRSRC)(1, 1) Call AddWorksheet(wshtName, myTable(iTASKRSRC))
'******************************************************* '2. Create a new task list based on xer data file '******************************************************** Temp = Array("task_id", "task", "Order", "Level", "wbs_id", "path", "Activity ID", "Activity Name", _ "target_labor", "Actual_Labor", "Remaining", "At_Completion", "od", "Start", "restart_Date", "Finish", _ "Act_Start", "Act_Finish", "Total_Float", "Duration_Pct", "Activity_Pct", "Labor_Earned_Value", _ "target_Non_labor", "Actual_Non_Labor", "Remaining_Non_Labor", "At_Completion_Non_Labor", "target_cost", "Actual_cost", "Remain_Cost", "At_Completion_cost") strSql1 = "SELECT [task_id],1,val([Order]),'', [TASK$].[wbs_id],[Path],[task_code],[task_name],val([target_work_qty])," & _ "val([act_work_qty]),[remain_work_qty],(val([act_work_qty])+[remain_work_qty]),iif(val([target_drtn_hr_cnt])=0,0.0000001, " & _ "val([target_drtn_hr_cnt]))," & _ "iif(isnull([act_start_date]),cdate([early_start_date]),cdate([act_start_date])) AS [start], cdate([restart_date]) as [restart],iif(isnull([act_end_date]),cdate([early_end_date]),cdate([act_end_date])) AS [finish]," & _ "cdate([act_start_date]),cdate([act_end_date])," & _ "(([total_float_hr_cnt])/[day_hr_cnt]) AS [TF_days]," & _ "iif(( Val([target_drtn_hr_cnt])= 0 OR val([target_drtn_hr_cnt]) val([remain_drtn_hr_cnt])),0, " & _ "cdbl(cdbl(val([target_drtn_hr_cnt])-val([remain_drtn_hr_cnt]))/cdbl(val([target_drtn_hr_cnt])))) as [D_percent]," & _ "iif([complete_pct_type]='CP_Drtn',[D_percent],iif([complete_pct_type]='CP_Phys',cdbl(val([phys_complete_pct]))/100,iif(val([remain_work_qty])+ " & _ "val([act_work_qty])+val([remain_equip_qty])+val([act_equip_qty])=0,0,cdbl((val([act_work_qty])+val([act_equip_qty]))/cdbl([remain_work_qty]+val([act_work_qty])+val([remain_equip_qty])+ " & _ "val([act_equip_qty])))))) as [percent] " & _ " ,(val([act_work_qty])+[remain_work_qty])* [percent],val([target_equip_qty]), val([act_equip_qty]),val([remain_equip_qty]),(val([act_equip_qty])+val([remain_equip_qty])) " & _ " FROM ([TASK$] INNER JOIN [CALENDAR$] ON [TASK$].[clndr_id] = [CALENDAR$].[clndr_id]) " & _ "INNER JOIN [myWBS$] on [TASK$].[wbs_id] = [myWBS$].[wbs_id] WHERE cstr([TASK$].[proj_id]) = " & ProjectID & " " myTemp = QueryResultArray(strSql1) r = UBound(myTemp) Dim myTaskpre() As Variant Erase myTaskpre ReDim Preserve myTaskpre(r + 2, 26 + 4) myTaskpre(1, 1) = "myTask" For i = 1 To 26 + 4 myTaskpre(2, i) = Temp(i) Next i For i = 1 To r For j = 1 To 26 myTaskpre(2 + i, j) = myTemp(i, j) Next j Next i Erase Temp Erase myTemp
'************************************************* '3. Create Cost data to append to the new task list '************************************************* Dim ddef_cost_per_qty As Double, def_cost_per_qty As Variant strSql1 = "SELECT [def_cost_per_qty] from [PROJECT$] where cstr([proj_id]) = " & ProjectID & "" def_cost_per_qty = QueryResultArray(strSql1) ddef_cost_per_qty = def_cost_per_qty(1, 1) Erase def_cost_per_qty If TASKRSRC = False Then strsql = "SELECT [task_id], sum(([target_work_qty]+[target_equip_qty])* " & ddef_cost_per_qty & " ) AS [Sum_target_cost]," & _ "sum(([act_work_qty]+[act_equip_qty])* " & ddef_cost_per_qty & " ) AS [Sum_Act_cost], " & _ "sum(([remain_work_qty]+[remain_equip_qty])* " & ddef_cost_per_qty & " ) AS [Sum_Remaining_cost], " & _ "[Sum_Act_cost]+[Sum_Remaining_cost] AS [Sum_Completion_cost]" & _ "from [TASK$] where cstr([proj_id]) = " & ProjectID & " GROUP BY [TASK$].[task_id] " End If If TASKRSRC = True Then strSQL2 = "SELECT [task_id],sum(val([target_cost])) AS [Sum_target_cost]," & _ "sum(val([act_ot_cost])+ val([act_reg_cost])) AS [Sum_Act_cost],sum(val([remain_cost])) " & _ "AS [Sum_Remaining_cost],[Sum_Act_cost]+[Sum_Remaining_cost] AS [Sum_Completion_cost]" & _ "from [TASKRSRC$] where cstr([proj_id]) = " & ProjectID & " GROUP BY [task_id] " strSQL3 = "SELECT [TASK$].[task_id], sum(([target_work_qty]+[target_equip_qty])* " & ddef_cost_per_qty & " ) AS [Sum_target_cost]," & _ "sum(([act_work_qty]+[act_equip_qty])* " & ddef_cost_per_qty & " ) AS [Sum_Act_cost], " & _ "sum(([remain_work_qty]+[remain_equip_qty])* " & ddef_cost_per_qty & " ) AS [Sum_Remaining_cost], " & _ "[Sum_Act_cost]+[Sum_Remaining_cost] AS [Sum_Completion_cost]" & _ "from [TASK$] LEFT JOIN [TASKRSRC$] ON [TASK$].[task_id] = [TASKRSRC$].[task_id] WHERE isnull([TASKRSRC$].[task_id]) and cstr([TASK$].[proj_id]) = " & ProjectID & " " & _ "GROUP BY [TASK$].[task_id] " strSQL4 = "SELECT t1.[task_id], ([target_work_qty]+[target_equip_qty]-t2.[sum_target_qty]) * " & ddef_cost_per_qty & " AS [Sum_target_cost], " & _ "([act_work_qty]+[act_equip_qty]-t2.[sum_act_qty])* " & ddef_cost_per_qty & " AS [Sum_Act_cost], " & _ "([remain_work_qty]+[remain_equip_qty]-t2.[sum_remain_qty])* " & ddef_cost_per_qty & " AS [Sum_Remaining_cost], " & _ "[Sum_Act_cost]+[Sum_Remaining_cost] AS [Sum_Completion_cost]" & _ "from [TASK$] as t1 INNER JOIN (SELECT [task_id], sum([target_qty]) as [sum_target_qty], sum(val([act_ot_qty])+val([act_reg_qty])) as [sum_act_qty],sum([remain_qty]) as [sum_remain_qty] from [TASKRSRC$] where cstr([proj_id]) = " & ProjectID & " GROUP BY [task_id] ) as t2 " & _ " ON t1.[task_id] = t2.[task_id]" strsql = strSQL2 & " UNION ALL " & strSQL3 & " UNION ALL " & strSQL4 End If If PROJCOST = True Then strSQL5 = "SELECT [task_id],[target_cost] AS [Sum_target_cost],[act_cost] AS [Sum_Act_cost] " & _ " ,[remain_cost] AS [Sum_Remaining_cost], [act_cost] + [remain_cost] AS [Sum_Completion_cost] from [PROJCOST$] where cstr([proj_id]) = " & ProjectID & "" strsql = strsql & " UNION ALL " & strSQL5 Else strSQLFinal = "SELECT [task_id], sum([Sum_target_cost]) AS [target_cost], " & _ "sum([Sum_Act_cost]) AS [Actual_cost], sum([Sum_Remaining_cost])AS [remain_cost]" & _ ",sum([Sum_Completion_cost]) AS [At_Completion_cost] from (" & strsql & ") GROUP BY [task_id]" End If Dim Tempcost As Variant Tempcost = QueryResultArray(strSQLFinal) For i = 3 To UBound(myTaskpre) DoEvents For j = 1 To UBound(Tempcost) If myTaskpre(i, 1) = Tempcost(j, 1) Then myTaskpre(i, 27) = Tempcost(j, 2) myTaskpre(i, 28) = Tempcost(j, 3) myTaskpre(i, 29) = Tempcost(j, 4) myTaskpre(i, 30) = Tempcost(j, 5) Exit For End If Next j Next i Erase Tempcost
'************************************************************* '4. Roll up data for each distinct paths. '************************************************************* Call DeleteWorksheet("myTask") wshtName = myTaskpre(1, 1) Call AddWorksheet(wshtName, myTaskpre) Dim HighLevelWBS As Variant Dim A1 As String, A2 As String, A3 As String, A4 As String, A5 As String, A6 As String, A7 As String, A8 As String A2 = ",sum(val([target_labor])) as [sum_target_labor], sum([Actual_Labor]) as [sum_Actual_Labor],sum([Remaining]) as [sum_Remaining],sum([At_Completion]) as [sum_At_Completion] " A3 = ",sum([od]) as [sum_T_OD] ,min([Start])as [M_Start],min(iif(not isnull([restart_date]),cdate([restart_date]),[restart_date])) as [M_restart] " A4 = ",max([Finish]) as [M_Finish],min([Act_Start]) as [M_Act_Start],max([Act_Finish]) as [M_Act_Finish],min([Total_Float]) as [Min_Total_Float]" A5 = ",iif([T_AC]=0,0,sum([At_Completion_cost]*[Activity_Pct])/[T_AC]) AS [A_Pct], sum([Labor_Earned_Value]) AS [sum_Labor_Earned_Value] " A6 = ",sum(val([target_Non_labor])) as [sum_target_Non_labor],sum(val([Actual_Non_Labor])) as [sum_Actual_Non_Labor]" A7 = ",sum(val([Remaining_Non_Labor])) as [sum_Remaining_Non_Labor],sum(val([At_Completion_Non_Labor])) as [sum_At_Completion_Non_Labor] " A8 = ",sum([target_cost]) as [sum_target_cost],sum([Actual_cost]) as[sum_Actual_cost],sum([remain_cost]) as[sum_remain_cost],sum([At_Completion_cost])as [T_AC] " strSql1 = "SELECT 'NA' AS [task_id],0 as [task],val([myWBS$].[Order]) as [order],[myWBS$].[Level],[myWBS$].[wbs_id],[myWBS$].[Path],[myWBS$].[wbs_name],'' as [Activity Name] " & _ A2 & A3 & A4 & A5 & A6 & A7 & A8 & _ "from [myWBS$] inner JOIN [myTask$] ON [myTask$].[wbs_id] = [myWBS$].[wbs_id] " & _ "GROUP BY [myWBS$].[Path],[myWBS$].[Order],[myWBS$].[Level],[myWBS$].[wbs_id],[myWBS$].[wbs_name]" strSQL2 = "SELECT 'NA' AS [task_id],0 as [task],val(t1.[Order]),t1.[Level],t1.[wbs_id],t1.[Path],t1.[wbs_name],'' as [Activity Name],sum([sum_target_labor]), sum([sum_Actual_Labor]),sum([sum_Remaining]),sum([sum_At_Completion])" & _ ",sum([sum_T_OD]) as [T_OD] ,min([M_Start])as [M_M_Start],min([M_restart])as [M_M_restart],max([M_Finish]) as [M_M_Finish],min([M_Act_Start]) as [M_M_Act_Start],max([M_Act_Finish]) as [M_M_Act_Finish],min([Min_Total_Float])," & _ "iif([Sum_T_AC]=0,0,sum([T_AC]*[A_Pct])/[Sum_T_AC] ) AS [sum_A_Pct], sum([sum_Labor_Earned_Value]) ,sum([sum_target_Non_labor]),sum([sum_Actual_Non_Labor]),sum([sum_Remaining_Non_Labor]),sum([sum_At_Completion_Non_Labor]), " & _ "sum([sum_target_cost]),sum([sum_Actual_cost]),sum([sum_remain_cost]),sum([T_AC]) as [Sum_T_AC] from [myWBS$] as t1 " & _ "inner JOIN (" & strSql1 & ") as t2 ON (t2.[Path] like t1.[Path] & '|%' ) " & _ " GROUP BY t1.[Path],t1.[Order],t1.[Level],t1.[wbs_id],t1.[wbs_name]" strSQL3 = strSql1 & " UNION ALL " & strSQL2 strsql = "SELECT [task_id],[task],[Order],[Level],[wbs_id],[Path],[wbs_name],'',sum([sum_target_labor]),sum([sum_Actual_Labor]),sum([sum_Remaining]),sum([sum_At_Completion])," & _ " sum([sum_T_OD]) as [T_OD] ,min([M_Start])as [M_M_Start],min([M_restart])as [M_M_restart],max([M_Finish]) as [M_M_Finish],min([M_Act_Start]),iif([Duration_Pct] =1 ,max([M_Act_Finish]),0),min([Min_Total_Float])," & _ "iif(isnull([M_M_restart]),1,iif(([M_M_restart]-[M_M_start])/([M_M_Finish]-[M_M_Start]) 0,0,iif(([M_M_restart]-[M_M_start])/ " & _ "([M_M_Finish]-[M_M_Start]) 1,1,([M_M_restart]-[M_M_start])/([M_M_Finish]-[M_M_Start])))) as [Duration_Pct]," & _ "iif([sum_T_AC]=0,0,sum([T_AC]*[A_Pct])/[sum_T_AC]) AS [sum_A_Pct], sum([sum_Labor_Earned_Value]), " & _ "sum([sum_target_Non_labor]),sum([sum_Actual_Non_Labor]),sum([sum_Remaining_Non_Labor]),sum([sum_At_Completion_Non_Labor])," & _ "SUM([sum_target_cost]),SUM([sum_Actual_cost]),SUM([sum_remain_cost]),SUM([T_AC]) as [sum_T_AC] " & _ "from (" & strSQL3 & ") GROUP BY [task],[Path],[Order],[Level],[wbs_id],[wbs_name],[task_id]" HighLevelWBS = QueryResultArray(strsql) Erase myTask Dim T As Long, H As Long T = UBound(myTaskpre): H = UBound(HighLevelWBS) ReDim Preserve myTask(T + H, 30) For i = 1 To T For j = 1 To 30 myTask(i, j) = myTaskpre(i, j) Next j Next i Erase myTaskpre For i = 1 To H For j = 1 To 30 myTask(T + i, j) = HighLevelWBS(i, j) Next j Next i Erase HighLevelWBS Call DeleteWorksheet("TASK") Call DeleteWorksheet("CALENDAR") Call DeleteWorksheet("myWBS") Call DeleteWorksheet("TASKRSRC") Call DeleteWorksheet("PROJECT") Call DeleteWorksheet("myTask")
'********************************************* '5. Generate data table data '********************************************* wshtName = myTask(1, 1) Call AddWorksheet(wshtName, myTask) strsql = "SELECT [task],[Order],[Level],[Activity ID],[Activity Name]" & _ ",[Start],[Finish],[Total_Float],cdate([Act_Start]) as [Actual Start] " & _ ",cdate(iif([Act_Finish]=0,'',[Act_Finish])) as [Actual_Finish],[restart_date],'' as [Forecast Finish],[Duration_Pct]" & _ ",[target_labor],[Actual_Labor],[Remaining],[At_Completion]" & _ ",[Activity_Pct],[Labor_Earned_Value]" & _ ",[target_Non_labor],[Actual_Non_Labor],[Remaining_Non_Labor],[At_Completion_Non_Labor]" & _ ",[target_cost],[Actual_cost],[remain_cost],[At_Completion_cost]" & _ "from [myTask$] order by [order],[task],[start]" Dim DataHeadings As Variant DataHeadings = Array("Level", "Activity", "Description" _ , "Start", "Finish", "Total Float", "Actual Start", "Actual Finish", "Remain Start", "Forecast Finish" _ , "Hours, Total", "Hours, Actual", "Hours, Remain", "Hours, Earned" _ , "Non-Labor, Total", "Non-Labor, Actual", "Non-Labor, Remain" _ , "Cost, Total", "Cost, Actual", "Cost, Remain") Dim myDataTemp As Variant myDataTemp = QueryResultArray(strsql) Erase myData ReDim Preserve myData(UBound(myDataTemp) + 1, 20) For i = 1 To 20 myData(1, i) = DataHeadings(i) Next i For i = 1 To UBound(myDataTemp) For j = 1 To 10 myData(i + 1, j) = myDataTemp(i, 2 + j) Next j For j = 1 To 3 myData(i + 1, 10 + j) = myDataTemp(i, 13 + j) Next j myData(i + 1, 14) = myDataTemp(i, 19) For j = 1 To 3 myData(i + 1, 14 + j) = myDataTemp(i, 19 + j) Next j For j = 1 To 3 myData(i + 1, 17 + j) = myDataTemp(i, 23 + j) Next j Next i Erase myDataTemp
'*********************************************************** '6. Populate a data table worksheet "myTask" '********************************************************** Call DeleteWorksheet("myTask") On Error Resume Next Set wb = ActiveWorkbook Set ws = wb.Worksheets("P6 Data") if err=0 then else Set ws = wb.Worksheets.Add(After:=Worksheets("P6 Summary")) ws.Name = "P6 Data" End If On Error GoTo 0 ws.Activate With ws .Cells.Clear .Cells.Borders.LineStyle = xlNone .Columns.ColumnWidth = 5 .Cells.Interior.Color = RGB(255, 255, 255) .Cells.Font.Bold = False End With r = 1: c = 1: rs = UBound(myData): cs = 20 ws.Cells(r, c).Resize(rs, cs).Value = myData Call Tableformat_Data(ws.Name, r, c, rs, cs) With ws .Cells(1, 1).Resize(1, 20).EntireColumn.HorizontalAlignment = xlCenter .Cells(1, 4).Resize(1, 7).EntireColumn.NumberFormat = Dateformat .Cells(1, 6).EntireColumn.NumberFormat = "0" .Cells(1, 11).Resize(1, 10).EntireColumn.NumberFormat = "#,##0.00" If .Cells(1, 2).EntireColumn.ColumnWidth > 30 Then .Cells(1, 2).EntireColumn.ColumnWidth = 30 End If If .Cells(1, 3).EntireColumn.ColumnWidth > 45 Then .Cells(1, 3).EntireColumn.ColumnWidth = 45 End If .Cells(1, 2).Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft .Cells(1, 2).Resize(1, 2).HorizontalAlignment = xlCenter End With For i = 2 To UBound(myData) If myData(i, 1) > 0 Then Select Case myData(i, 1) Case 1 With ws.Cells(i, 1).Resize(1, 20) .Interior.ColorIndex = 8 .Font.Bold = True End With Case 2 With ws.Cells(i, 1).Resize(1, 20) .Interior.ColorIndex = 18 .Font.Bold = True End With Case 3 With ws.Cells(i, 1).Resize(1, 20) .Interior.ColorIndex = 33 .Font.Bold = True End With Case 4 With ws.Cells(i, 1).Resize(1, 20) .Interior.ColorIndex = 46 .Font.Bold = True End With Case 5 With ws.Cells(i, 1).Resize(1, 20) .Interior.ColorIndex = 54 .Font.Bold = True End With End Select End If Next i Application.StatusBar = False End Sub
Data processing requires mutiple data tables
and thus data processing with VBA programming language (array, looping and so on) requires extensive coding effort.
SQL can make the coding work much simpler using SQL Connection for Excel VBA than VBA programming.
This is possible by using the ADO connect to Excel driver or Access Database. The current ADO connect is based on the ADO connect to Access Database and late binding to the needed object libraries.
Sql query string is passed to the Function QueryResultArray() below to handle the SQL query like Microsoft Access or SQL server.
Sub ExampleSQL() 'An Example SQL Query as a stirng strsql = "SELECT Sum([act_work_qty]) FROM [TASK$] where cstr([proj_id]) = " & ProjectID & "" dAct_work_qty = QueryResultArray(strsql) dAct_work_qty = Format(dAct_work_qty(1, 1), "#,##0.00") End Sub
Function QueryResultArray(sqlquery As String) As Variant '4. Microsoft.ACE.OLEDB-Late Binding Dim rst As Object Dim MyConnect As String Dim arrResults() As Variant, i As Long, n As Long DoEvents Set rst = CreateObject("ADODB.Recordset") MyConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & ActiveWorkbook.FullName & ";" & _ "Extended Properties=Excel 12.0" With rst .Open sqlquery, MyConnect .MoveFirst n = 0 Do Until .EOF n = n + 1 .MoveNext Loop Erase arrResults ReDim Preserve arrResults(n, .Fields.Count) .MoveFirst n = 0 Do Until .EOF n = n + 1 For i = 1 To .Fields.Count On Error Resume Next arrResults(n, i) = .Fields(i - 1) On Error GoTo 0 Next i .MoveNext Loop End With QueryResultArray = arrResults Set rst = Nothing MyConnect = "" End Function
On top of this page, the following pages can help you read/parse Xer file to Excel, consolidate project data and create project calendar and to do so, visit the pages below.
Xer (P6 text file) written to Excel P6-project summary based on p6 xer file
The downloadable application covers four(4) pages:Read/parse Xer data, P6 summary, P6 data table, and P6 Calendar.
Download Excel add-in and a workbook for demonstrationIt is necessary to install the downloaded Excel Add-in. To do so, visit the page below.
Create and load Excel Add-in
Modified on:3-November-2019
Dated on: 4-October-2019