Macro para crear un diagrama Gantt en Excel y exportar a html y/o MS Project
En ocasiones debemos crear diagramas Gantt para el control de proyectos y resulta mas sencillo manipular los datos desde Excel que desde Project. En otras ocasiones, simplemente no se dispone de una licencia de Project para el contro del projecto.
Este post es sobre una herramienta en Excel que he diseñado en la que se puede crear un proyecto en blanco y a partir de la cual se pueden exportar los datos bien sea hacia un servidor para visualizar el proyecto en formato Gantt, o simplemente hacia MS Project.
Nota técnica: Para que la solución funcione correctamente, es necesario tener instalado MS Excel y Project (opcional) 2010, asi como un servidor local, yo particularmente utilizo XAMPP pero está en cada usuario como desea aplicarlo. Finalmente, es necesario tener JSGantt que es un desarrollo en javascript que permite crear diagramas Gantt en web.
Los archivos pueden ser descargados en el siguiente vinculo.
A continuación describiremos en detalle los dos métodos :
1) MS Project
Para conectar Excel con Project es necesario tener instalados ambos programas en su ordenador (versión 2010 = 14.0). A partir de su editor VBA es necesario agregar la referencia Microsoft Project 14.0 Object Library (ver imagen)
Esto permite crear objetos de tipo MSProject.Application y sus componentes.
La siguiente función permite integrar la referencia de MS Project al código. Este paso puede ser redundante si usted ya agregó la referencia como se mostró en el paso anterior, sin embargo es una validación útil.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
Sub AddReferenceToProject() Dim Major As Long Dim Minor As Long On Error Resume Next Major = 1 For Minor = 7 To 5 Step -1 Err.Clear ActiveWorkbook.VBProject.references.AddFromGuid _ "{A7107640-94DF-1068-855E-00DD01075445}", Major, Minor If Err.Number = 0 Then Exit For End If Next Minor End Sub |
La siguiente función valida si la información ingresada corresponde o no a una fecha.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
Function getDate(d As Date) As String Dim yyyy, mm, dd As String If IsDate(d) And d > 0 Then yyyy = Year(d) mm = Month(d) If Len(mm) = 1 Then mm = "0" & mm End If dd = Day(d) If Len(dd) = 1 Then dd = "0" & dd End If getDate = mm & "/" & dd & "/" & yyyy Else getDate = "" End If End Function |
La siguiente función retorna el color utilizado en una celda en código hexadecimal
|
1 2 3 4 5 6 7 8 9 10 11 |
Function getHex(cel As Range) As String Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim str0 As String, str As String str0 = Right("000000" & Hex(cel.Interior.Color), 6) str = LCase(Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)) getHex = str done: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Function |
2) Servidor web
En primer lugar es necesario contar con un servidor local, para esto he utilizado XAMPP.
Una vez configurado, es necesario crear un folder de destinación de los archivos
El folder elegido (C:\xampp\htdocs\Tools\gantt\Data) puede ser accedido localmente si el servidor se encuentra en el mismo ordernador, o por red si se trata de una red interna.
En nuestro caso hemos habilitado un folder compartido en la dirección \\100177A\Data\, en donde se puede acceder remotamente para guardar el archivo xml necesario para generar el diagrama de Gantt.
Este archivo xml es generado en Excel en la siguiente función (createXML)
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
Public Sub createXML() Application.Calculation = xlAutomatic Dim s1, s2 As Worksheet Dim ss, pred, shex As String Dim pid, pid_1, lPid(), ch, lProj() As Long Dim lev, lev_1, consec, consec_1, nlevel, pGrup, pParent, pParent_1, tempValue, tempValue1 As Integer Dim mil As Integer Set s1 = Sheets(ActiveSheet.Index) Dim name As String Dim i, j As Long name = "xmlFile" ' Worksheet we want to put the report into Dim ws As Worksheet For Each ws In ThisWorkbook.Sheets If ws.name = name Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True Exit For End If Next With Sheets.Add(, Sheets(Sheets.Count)) .name = name .Visible = False End With Set s2 = Sheets(Sheets.Count) s2.Cells(1, 1) = "<project>" s2.Cells(2, 1) = "<task>" s2.Cells(3, 1) = " <pID>1</pID>" 'Change s2.Cells(4, 1) = " <pName>" & s1.Cells(2, 2) & "</pName>" s2.Cells(5, 1) = " <pStart> </pStart>" s2.Cells(6, 1) = " <pEnd> </pEnd>" s2.Cells(7, 1) = " <pColor></pColor>" s2.Cells(8, 1) = " <pLink>http://100177a/Projects/CD2/CD2index.html</pLink>" s2.Cells(9, 1) = " <pMile>0</pMile>" s2.Cells(10, 1) = " <pRes> </pRes>" s2.Cells(11, 1) = " <pComp> </pComp>" s2.Cells(12, 1) = " <pGroup>1</pGroup>" s2.Cells(13, 1) = " <pParent>0</pParent>" s2.Cells(14, 1) = " <pOpen>1</pOpen>" s2.Cells(15, 1) = " <pDepend></pDepend>" s2.Cells(16, 1) = " <pCaption> </pCaption>" s2.Cells(17, 1) = "</task>" i = 5 j = 17 lev_1 = 0 While s1.Cells(i, 2) <> "" pred = "" If (i = 5) Then ReDim lPid(0) Else ReDim Preserve lPid(UBound(lPid) + 1) End If ss = Trim(s1.Cells(i, 2)) If getInd(s1.Cells(i, 2)) + 1 = 1 Then nlevel = nlevel + 1 ss = nlevel & " - " & ss End If lev = getInd(s1.Cells(i, 2)) + 1 If lev_1 = lev Then consec = consec_1 + 1 pid = pid + 1 Else consec = 1 If lev > 1 Then tempValue = 1 Else tempValue = 0 End If pid = 10 ^ (getInd(s1.Cells(i, 2)) + 1) + nlevel * 10 ^ (lev - 1) + tempValue End If If s1.Cells(i + 1, 2) <> "" And getInd(s1.Cells(i + 1, 2)) + 1 > lev Then pGrup = 1 Else pGrup = 0 End If If lev = 1 Then pParent = 1 Else If consec = 1 Then pParent = pid_1 Else pParent = pParent_1 End If End If If s1.Cells(i, 9) <> "" Then ch = Split(s1.Cells(i, 9), ",") tempValue = 0 For tempValue = 0 To UBound(ch) For tempValue1 = 5 To i If ch(tempValue) * 1 = s1.Cells(tempValue1, 1) Then If tempValue = 0 Then pred = lPid(tempValue1 - 5) ' & "(" & s1.Cells(tempValue1, 1) & ")" Else pred = pred & ", " & lPid(tempValue1 - 5) ' & "(" & s1.Cells(tempValue1, 1) & ")" End If End If Next tempValue1 Next tempValue End If lPid(UBound(lPid)) = pid pid_1 = pid pParent_1 = pParent consec_1 = consec lev_1 = lev If getHex(s1.Cells(i, 2)) = "ffffff" Then shex = "808080" Else shex = getHex(s1.Cells(i, 2)) End If mil = 0 If s1.Cells(i, 10) = "Yes" Then mil = 1 End If s2.Cells(j + 1, 1) = "<task>" s2.Cells(j + 2, 1) = " <pID>" & pid & "</pID>" 'Change s2.Cells(j + 3, 1) = " <pName>" & ss & "</pName>" s2.Cells(j + 4, 1) = " <pStart>" & getDate(s1.Cells(i, 4)) & "</pStart>" s2.Cells(j + 5, 1) = " <pEnd>" & getDate(s1.Cells(i, 5)) & "</pEnd>" s2.Cells(j + 6, 1) = " <pColor>" & shex & "</pColor>" s2.Cells(j + 7, 1) = " <pLink>" & s1.Cells(i, 11) & "</pLink>" s2.Cells(j + 8, 1) = " <pMile>" & mil & "</pMile>" s2.Cells(j + 9, 1) = " <pRes>" & s1.Cells(i, 6) & "</pRes>" s2.Cells(j + 10, 1) = " <pComp>" & s1.Cells(i, 7) * 100 & "</pComp>" s2.Cells(j + 11, 1) = " <pGroup>" & pGrup & "</pGroup>" s2.Cells(j + 12, 1) = " <pParent>" & pParent & "</pParent>" s2.Cells(j + 13, 1) = " <pOpen>" & 1 & "</pOpen>" s2.Cells(j + 14, 1) = " <pDepend>" & pred & "</pDepend>" 's1.Cells(i, 9) s2.Cells(j + 15, 1) = " <pCaption> 'hello' </pCaption>" s2.Cells(j + 16, 1) = "</task>" i = i + 1 j = j + 17 Wend s2.Cells(j, 1) = "</project>" Application.DisplayAlerts = False Sheets("xmlFile").Visible = True Sheets("xmlFile").Select Sheets("xmlFile").Copy ActiveWorkbook.SaveAs Filename:= _ "\\100177A\Data\project.xml" _ , FileFormat:=xlUnicodeText, CreateBackup:=False ActiveWindow.Close Sheets("xmlFile").Delete s1.Select Application.DisplayAlerts = True Unload frmGantt msb = MsgBox("The gantt chart was updated, do you want to visit the web version?", vbYesNo, "Gantt webb") If msb = vbYes Then ActiveWorkbook.FollowHyperlink "http://100177a/Tools/gantt/TrGantt.html", , True End If End Sub |
Las últimas líneas del código simplemente abren el browser en la dirección deseada (la misma habilitada en el servidor para ejecutar la herramienta), en este caso http://100177a/Tools/gantt/TrGantt.html. Un ejemplo de como se vería este diagrama se encuentra en el siguiente link.
En cuanto al archivo html, utilizamos cualquier plantilla de base y en ella insertamos un script haciendo referencia a la librería JSGantt (incluída en los archivos adjuntos). Los comandos para crear el diagrama se muestran en la siguiente imagen:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
<script language="javascript"> var g = new JSGantt.GanttChart('g',document.getElementById('GanttChartDIV'), 'quarter'); g.setShowRes(1); // Show/Hide Responsible (0/1) g.setShowDur(1); // Show/Hide Duration (0/1) g.setShowComp(1); // Show/Hide % Complete(0/1) g.setCaptionType('Resource'); // Set to Show Caption (None,Caption,Resource,Duration,Complete) if( g ) { // Parameters (pID, pName, pStart, pEnd, pColor, pLink, pMile, pRes, pComp, pGroup, pParent, pOpen, pDepend, pCaption) // You can also use the XML file parser JSGantt.parseXML('project.xml',g) JSGantt.parseXML('Data/project.xml',g) g.Draw(); g.DrawDependencies(); } else { alert("not defined"); } </script> |
Finalmente, el código para exportar la información desde Excel hacia MS Project es el siguiente (recuerde importar la librería antes)
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
Sub CreateProjectFileNew() Dim SN As String Dim lastrow, lastcol As Integer Dim i, j, K As Integer Dim selran As Range Dim maxd As Double Dim s1 As Worksheet Set s1 = ActiveSheet SN = ActiveSheet.name Dim srange As Range Dim duedate As Date Range("B5").Select Selection.End(xlDown).Select lastrow = Selection.Row For i = 5 To lastrow If s1.Cells(i, 5) > maxd Then maxd = s1.Cells(i, 5) End If Next i Range("A1").Select Selection.End(xlToRight).Select lastcol = Selection.Column duedate = maxd 'Cells(lastrow + 0, 5) Range(Cells(5, 1), Cells(lastrow, lastcol)).Select Set selran = Selection On Error Resume Next Range("H1").Select Dim projApp As MSProject.Application On Error Resume Next Set projApp = GetObject(, "MSProject.Application") If projApp Is Nothing Then Set projApp = New MSProject.Application Else MsgBox "There is already a MSProject oppened (" & projApp.ActiveProject.name & ")" Exit Sub End If ' #If ReferenceMSProject Then ' Dim projApp As New MSProject.Application ' #Else ' Dim projApp As Object ' Set proapp = CreateObject("MSProject.Application") ' #End If projApp.FileNew Template:="" projApp.Visible = True #If ReferenceMSProject Then Dim prjPCC As Project #Else Dim prjPCC As Object #End If Set prjPCC = projApp.ActiveProject projApp.SetTaskMode Manual i = 4 '#If ReferenceMSProject Then Dim tsk As Task '#Else 'Dim tsk As Object '#End If Dim dd, dat, ddef, tt As String While s1.Cells(i + 1, 2) <> "" tt = Mid(s1.Cells(i + 1, 2), 1, 20) Dim a As Integer If IsError(prjPCC.NumberOfTasks) Then a = 0 Else a = prjPCC.NumberOfTasks End If Task = prjPCC.Tasks.Add(tt, a + 1) Set tsk = prjPCC.Tasks(i - 3) If getInd(s1.Cells(i + 2, 2)) > getInd(s1.Cells(i + 1, 2)) Then tsk.Manual = False Else tsk.Manual = True End If dd = Mid(WeekdayName(Weekday(CDate(s1.Cells(i + 1, 4)))), 1, 3) dat = str(s1.Cells(i + 1, 4)) ddef = dd & " " & dat tsk.Start = ddef dd = Mid(WeekdayName(Weekday(CDate(s1.Cells(i + 1, 5)))), 1, 3) dat = str(s1.Cells(i + 1, 5)) ddef = dd & " " & dat tsk.Finish = ddef tsk.PercentComplete = str(s1.Cells(i + 1, 7) * 100) & "%" tsk.ResourceNames = s1.Cells(i + 1, 6) tsk.Text1 = s1.Cells(i + 1, 8) tsk.Text2 = s1.Cells(i + 1, 11) If s1.Cells(i + 1, 9) <> "" Then If s1.Cells(i + 1, 9) <> "" Then tsk.Predecessors = s1.Cells(i + 1, 9) & "FS-1 day" End If End If Dim deadl As Date deadl = Format(duedate, dateform) tsk.deadline = deadl tsk.OutlineLevel = getInd(s1.Cells(i + 1, 2)) + 1 i = i + 1 Wend projApp.AddNewColumn ("Text1") projApp.AddNewColumn ("Text2") 'Tidy up Set projApp = Nothing next2: End Sub |
El siguiente video es una demonstración de como funciona el archivo Excel exportando a MS Project y a el servidor Web.
curso excel madrid
Great post! Have nice day ! 🙂 rxywk