{"id":350,"date":"2015-09-02T19:42:48","date_gmt":"2015-09-03T01:42:48","guid":{"rendered":"http:\/\/agiltools.com\/blogsp\/?p=350"},"modified":"2015-11-16T01:16:17","modified_gmt":"2015-11-16T07:16:17","slug":"gantt_excel","status":"publish","type":"post","link":"https:\/\/agiltools.com\/blogsp\/gantt_excel\/","title":{"rendered":"Macro para crear un diagrama Gantt en Excel y exportar a html y\/o MS Project"},"content":{"rendered":"

En ocasiones debemos crear diagramas Gantt para el control de proyectos y resulta mas sencillo manipular los datos desde Excel que desde Project.\u00a0En otras ocasiones, simplemente no se dispone de una licencia de Project para el contro del projecto.<\/p>\n

Este post es sobre una herramienta en Excel que he dise\u00f1ado en la que se puede crear un proyecto en blanco y\u00a0a partir de la cual se pueden exportar los datos bien sea hacia un servidor para visualizar el proyecto en formato Gantt, o simplemente\u00a0hacia MS Project.<\/p>\n

 <\/p>\n

\"gantt1\"<\/a><\/p>\n

Nota t\u00e9cnica:<\/strong> Para que la soluci\u00f3n funcione correctamente, es necesario tener instalado MS Excel y Project (opcional) 2010, asi como un servidor local, yo particularmente\u00a0utilizo XAMPP<\/a> pero est\u00e1 en cada usuario como desea aplicarlo. Finalmente, es necesario tener\u00a0JSGantt que es un desarrollo en javascript que permite crear diagramas Gantt en web.<\/p>\n

Los archivos\u00a0pueden ser descargados en el siguiente vinculo<\/a>.<\/p>\n

<\/p>\n

A continuaci\u00f3n describiremos en detalle los dos m\u00e9todos :<\/p>\n

1) MS Project<\/h2>\n

Para conectar Excel con Project es necesario tener instalados ambos programas en su ordenador (versi\u00f3n 2010 = 14.0). \u00a0A partir de su editor VBA es necesario agregar la referencia Microsoft Project 14.0 Object Library\u00a0<\/strong>(ver imagen)<\/p>\n

\"references\"<\/a><\/p>\n

 <\/p>\n

Esto permite crear objetos de tipo\u00a0MSProject.Application y sus componentes.<\/p>\n

La siguiente funci\u00f3n permite integrar la referencia de MS Project al c\u00f3digo. Este paso puede ser redundante si usted ya agreg\u00f3 la referencia como se mostr\u00f3 en el paso anterior, sin embargo es una validaci\u00f3n \u00fatil.<\/p>\n

Sub AddReferenceToProject()\r\nDim Major As Long\r\nDim Minor As Long\r\n    On Error Resume Next\r\n    Major = 1\r\n    For Minor = 7 To 5 Step -1\r\n        Err.Clear\r\n        ActiveWorkbook.VBProject.references.AddFromGuid _\r\n            \"{A7107640-94DF-1068-855E-00DD01075445}\", Major, Minor\r\n        If Err.Number = 0 Then\r\n            Exit For\r\n        End If\r\n    Next Minor\r\nEnd Sub<\/pre>\n
La siguiente funci\u00f3n valida si la informaci\u00f3n ingresada corresponde o no a una fecha.<\/p>\n
Function getDate(d As Date) As String\r\nDim yyyy, mm, dd As String\r\nIf IsDate(d) And d > 0 Then\r\n    yyyy = Year(d)\r\n    mm = Month(d)\r\n    If Len(mm) = 1 Then\r\n        mm = \"0\" & mm\r\n    End If\r\n    dd = Day(d)\r\n    If Len(dd) = 1 Then\r\n        dd = \"0\" & dd\r\n    End If\r\n    getDate = mm & \"\/\" & dd & \"\/\" & yyyy\r\nElse\r\n    getDate = \"\"\r\nEnd If\r\nEnd Function<\/pre>\n
La siguiente funci\u00f3n retorna el color utilizado en una celda en c\u00f3digo hexadecimal<\/p>\n
Function getHex(cel As Range) As String\r\n    Application.ScreenUpdating = False\r\n    Application.Calculation = xlCalculationManual\r\n    Dim str0 As String, str As String\r\n    str0 = Right(\"000000\" & Hex(cel.Interior.Color), 6)\r\n    str = LCase(Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2))\r\n    getHex = str\r\ndone:\r\n    Application.Calculation = xlCalculationAutomatic\r\n    Application.ScreenUpdating = True\r\nEnd Function<\/pre>\n
2) Servidor web<\/h2>\n
En primer lugar es necesario contar con un servidor local, para esto he utilizado XAMPP.<\/p>\n
\"xampp\"<\/a><\/p>\n
Una vez configurado, es necesario crear un folder de destinaci\u00f3n de los archivos<\/p>\n
\"path<\/a><\/p>\n
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.<\/p>\n
\"Sharing<\/a><\/p>\n
\"Access<\/a><\/p>\n
En nuestro caso hemos habilitado un folder compartido en la direcci\u00f3n \\\\100177A\\Data\\, en donde se puede acceder remotamente para guardar el archivo xml necesario para generar el diagrama de Gantt.<\/p>\n
Este archivo xml es generado en Excel en la siguiente funci\u00f3n (createXML)<\/p>\n
Public Sub createXML()\r\nApplication.Calculation = xlAutomatic\r\nDim s1, s2 As Worksheet\r\nDim ss, pred, shex As String\r\nDim pid, pid_1, lPid(), ch, lProj() As Long\r\nDim lev, lev_1, consec, consec_1, nlevel, pGrup, pParent, pParent_1, tempValue, tempValue1 As Integer\r\nDim mil As Integer\r\n\r\nSet s1 = Sheets(ActiveSheet.Index)\r\nDim name As String\r\nDim i, j As Long\r\nname = \"xmlFile\"\r\n' Worksheet we want to put the report into\r\n    Dim ws As Worksheet\r\n    For Each ws In ThisWorkbook.Sheets\r\n        If ws.name = name Then\r\n            Application.DisplayAlerts = False\r\n            ws.Delete\r\n            Application.DisplayAlerts = True\r\n            Exit For\r\n            \r\n        End If\r\n    Next\r\nWith Sheets.Add(, Sheets(Sheets.Count))\r\n    .name = name\r\n    .Visible = False\r\nEnd With\r\nSet s2 = Sheets(Sheets.Count)\r\ns2.Cells(1, 1) = \"<project>\"\r\ns2.Cells(2, 1) = \"<task>\"\r\ns2.Cells(3, 1) = \"    <pID>1<\/pID>\" 'Change\r\ns2.Cells(4, 1) = \"    <pName>\" & s1.Cells(2, 2) & \"<\/pName>\"\r\ns2.Cells(5, 1) = \"    <pStart> <\/pStart>\"\r\ns2.Cells(6, 1) = \"    <pEnd> <\/pEnd>\"\r\ns2.Cells(7, 1) = \"    <pColor><\/pColor>\"\r\ns2.Cells(8, 1) = \"    <pLink>http:\/\/100177a\/Projects\/CD2\/CD2index.html<\/pLink>\"\r\ns2.Cells(9, 1) = \"    <pMile>0<\/pMile>\"\r\ns2.Cells(10, 1) = \"    <pRes>  <\/pRes>\"\r\ns2.Cells(11, 1) = \"    <pComp> <\/pComp>\"\r\ns2.Cells(12, 1) = \"    <pGroup>1<\/pGroup>\"\r\ns2.Cells(13, 1) = \"    <pParent>0<\/pParent>\"\r\ns2.Cells(14, 1) = \"    <pOpen>1<\/pOpen>\"\r\ns2.Cells(15, 1) = \"    <pDepend><\/pDepend>\"\r\ns2.Cells(16, 1) = \"    <pCaption>  <\/pCaption>\"\r\ns2.Cells(17, 1) = \"<\/task>\"\r\ni = 5\r\nj = 17\r\nlev_1 = 0\r\nWhile s1.Cells(i, 2) <> \"\"\r\n    pred = \"\"\r\n    If (i = 5) Then\r\n        ReDim lPid(0)\r\n    Else\r\n        ReDim Preserve lPid(UBound(lPid) + 1)\r\n    End If\r\n    ss = Trim(s1.Cells(i, 2))\r\n    If getInd(s1.Cells(i, 2)) + 1 = 1 Then\r\n        nlevel = nlevel + 1\r\n        ss = nlevel & \" - \" & ss\r\n    End If\r\n    lev = getInd(s1.Cells(i, 2)) + 1\r\n    If lev_1 = lev Then\r\n        consec = consec_1 + 1\r\n        pid = pid + 1\r\n    Else\r\n        consec = 1\r\n        If lev > 1 Then\r\n            tempValue = 1\r\n        Else\r\n            tempValue = 0\r\n        End If\r\n        pid = 10 ^ (getInd(s1.Cells(i, 2)) + 1) + nlevel * 10 ^ (lev - 1) + tempValue\r\n    End If\r\n    \r\n    If s1.Cells(i + 1, 2) <> \"\" And getInd(s1.Cells(i + 1, 2)) + 1 > lev Then\r\n        pGrup = 1\r\n    Else\r\n        pGrup = 0\r\n    End If\r\n    If lev = 1 Then\r\n        pParent = 1\r\n    Else\r\n        If consec = 1 Then\r\n            pParent = pid_1\r\n        Else\r\n            pParent = pParent_1\r\n        End If\r\n    End If\r\n    If s1.Cells(i, 9) <> \"\" Then\r\n        ch = Split(s1.Cells(i, 9), \",\")\r\n        tempValue = 0\r\n        For tempValue = 0 To UBound(ch)\r\n            For tempValue1 = 5 To i\r\n                If ch(tempValue) * 1 = s1.Cells(tempValue1, 1) Then\r\n                    If tempValue = 0 Then\r\n                        pred = lPid(tempValue1 - 5) ' & \"(\" & s1.Cells(tempValue1, 1) & \")\"\r\n                    Else\r\n                        pred = pred & \", \" & lPid(tempValue1 - 5) ' & \"(\" & s1.Cells(tempValue1, 1) & \")\"\r\n                    End If\r\n                End If\r\n            Next tempValue1\r\n        Next tempValue\r\n    End If\r\n    lPid(UBound(lPid)) = pid\r\n    pid_1 = pid\r\n    pParent_1 = pParent\r\n    consec_1 = consec\r\n    lev_1 = lev\r\n    If getHex(s1.Cells(i, 2)) = \"ffffff\" Then\r\n            shex = \"808080\"\r\n    Else\r\n            shex = getHex(s1.Cells(i, 2))\r\n    End If\r\n    mil = 0\r\n    If s1.Cells(i, 10) = \"Yes\" Then\r\n        mil = 1\r\n    End If\r\n    s2.Cells(j + 1, 1) = \"<task>\"\r\n    s2.Cells(j + 2, 1) = \"    <pID>\" & pid & \"<\/pID>\" 'Change\r\n    s2.Cells(j + 3, 1) = \"    <pName>\" & ss & \"<\/pName>\"\r\n    s2.Cells(j + 4, 1) = \"    <pStart>\" & getDate(s1.Cells(i, 4)) & \"<\/pStart>\"\r\n    s2.Cells(j + 5, 1) = \"    <pEnd>\" & getDate(s1.Cells(i, 5)) & \"<\/pEnd>\"\r\n    s2.Cells(j + 6, 1) = \"    <pColor>\" & shex & \"<\/pColor>\"\r\n    s2.Cells(j + 7, 1) = \"    <pLink>\" & s1.Cells(i, 11) & \"<\/pLink>\"\r\n    s2.Cells(j + 8, 1) = \"    <pMile>\" & mil & \"<\/pMile>\"\r\n    s2.Cells(j + 9, 1) = \"    <pRes>\" & s1.Cells(i, 6) & \"<\/pRes>\"\r\n    s2.Cells(j + 10, 1) = \"    <pComp>\" & s1.Cells(i, 7) * 100 & \"<\/pComp>\"\r\n    s2.Cells(j + 11, 1) = \"    <pGroup>\" & pGrup & \"<\/pGroup>\"\r\n    s2.Cells(j + 12, 1) = \"    <pParent>\" & pParent & \"<\/pParent>\"\r\n    s2.Cells(j + 13, 1) = \"    <pOpen>\" & 1 & \"<\/pOpen>\"\r\n    s2.Cells(j + 14, 1) = \"    <pDepend>\" & pred & \"<\/pDepend>\" 's1.Cells(i, 9)\r\n    s2.Cells(j + 15, 1) = \"    <pCaption> 'hello' <\/pCaption>\"\r\n    s2.Cells(j + 16, 1) = \"<\/task>\"\r\n    i = i + 1\r\n    j = j + 17\r\nWend\r\ns2.Cells(j, 1) = \"<\/project>\"\r\nApplication.DisplayAlerts = False\r\nSheets(\"xmlFile\").Visible = True\r\nSheets(\"xmlFile\").Select\r\n    Sheets(\"xmlFile\").Copy\r\n    ActiveWorkbook.SaveAs Filename:= _\r\n        \"\\\\100177A\\Data\\project.xml\" _\r\n        , FileFormat:=xlUnicodeText, CreateBackup:=False\r\n    ActiveWindow.Close\r\n    Sheets(\"xmlFile\").Delete\r\n    s1.Select\r\nApplication.DisplayAlerts = True\r\nUnload frmGantt\r\nmsb = MsgBox(\"The gantt chart was updated, do you want to visit the web version?\", vbYesNo, \"Gantt webb\")\r\nIf msb = vbYes Then\r\n    ActiveWorkbook.FollowHyperlink \"http:\/\/100177a\/Tools\/gantt\/TrGantt.html\", , True\r\n\r\nEnd If\r\n\r\nEnd Sub<\/pre>\n
Las \u00faltimas l\u00edneas del c\u00f3digo simplemente\u00a0abren el browser en la direcci\u00f3n deseada (la misma habilitada en el servidor para ejecutar la herramienta), en este caso\u00a0http:\/\/100177a\/Tools\/gantt\/TrGantt.html. Un ejemplo de como se ver\u00eda este diagrama se encuentra en el siguiente link<\/a>.<\/p>\n
En cuanto al archivo html, utilizamos cualquier plantilla de base y en ella insertamos un script haciendo referencia a la librer\u00eda JSGantt <\/a>(inclu\u00edda en los archivos adjuntos). Los comandos para crear el diagrama se muestran en la siguiente imagen:<\/p>\n
<script language=\"javascript\">\r\nvar g = new JSGantt.GanttChart('g',document.getElementById('GanttChartDIV'), 'quarter');\r\ng.setShowRes(1); \/\/ Show\/Hide Responsible (0\/1)\r\ng.setShowDur(1); \/\/ Show\/Hide Duration (0\/1)\r\ng.setShowComp(1); \/\/ Show\/Hide % Complete(0\/1)\r\ng.setCaptionType('Resource'); \/\/ Set to Show Caption (None,Caption,Resource,Duration,Complete)\r\nif( g ) {\r\n\/\/ Parameters (pID, pName, pStart, pEnd, pColor, pLink, pMile, pRes, pComp, pGroup, pParent, pOpen, pDepend, pCaption)\r\n\/\/ You can also use the XML file parser JSGantt.parseXML('project.xml',g)\r\n\tJSGantt.parseXML('Data\/project.xml',g)\r\n    g.Draw(); \r\n\tg.DrawDependencies();\r\n}\r\nelse\r\n{\r\nalert(\"not defined\");\r\n}\r\n<\/script><\/pre>\n
Finalmente, el c\u00f3digo para exportar la informaci\u00f3n desde Excel hacia MS Project es el siguiente (recuerde importar la librer\u00eda antes)<\/p>\n
Sub CreateProjectFileNew()\r\nDim SN As String\r\nDim lastrow, lastcol As Integer\r\nDim i, j, K As Integer\r\nDim selran As Range\r\nDim maxd As Double\r\nDim s1 As Worksheet\r\nSet s1 = ActiveSheet\r\nSN = ActiveSheet.name\r\nDim srange As Range\r\nDim duedate As Date\r\nRange(\"B5\").Select\r\nSelection.End(xlDown).Select\r\nlastrow = Selection.Row\r\nFor i = 5 To lastrow\r\n    If s1.Cells(i, 5) > maxd Then\r\n        maxd = s1.Cells(i, 5)\r\n    End If\r\nNext i\r\nRange(\"A1\").Select\r\nSelection.End(xlToRight).Select\r\nlastcol = Selection.Column\r\nduedate = maxd 'Cells(lastrow + 0, 5)\r\nRange(Cells(5, 1), Cells(lastrow, lastcol)).Select\r\nSet selran = Selection\r\nOn Error Resume Next\r\n    Range(\"H1\").Select\r\n    Dim projApp As MSProject.Application\r\n    On Error Resume Next\r\n    Set projApp = GetObject(, \"MSProject.Application\")\r\n    If projApp Is Nothing Then\r\n        Set projApp = New MSProject.Application\r\n    Else\r\n        MsgBox \"There is already a MSProject oppened (\" & projApp.ActiveProject.name & \")\"\r\n        Exit Sub\r\n    End If\r\n    \r\n'    #If ReferenceMSProject Then\r\n'    Dim projApp As New MSProject.Application\r\n'    #Else\r\n'    Dim projApp As Object\r\n'    Set proapp = CreateObject(\"MSProject.Application\")\r\n'    #End If\r\n    \r\n    projApp.FileNew Template:=\"\"\r\n    projApp.Visible = True\r\n    \r\n    #If ReferenceMSProject Then\r\n    Dim prjPCC As Project\r\n    #Else\r\n    Dim prjPCC As Object\r\n    #End If\r\n    Set prjPCC = projApp.ActiveProject\r\n    \r\n    projApp.SetTaskMode Manual\r\n    \r\n    \r\n    i = 4\r\n    '#If ReferenceMSProject Then\r\n    Dim tsk As Task\r\n    '#Else\r\n    'Dim tsk As Object\r\n    '#End If\r\n    Dim dd, dat, ddef, tt As String\r\n    While s1.Cells(i + 1, 2) <> \"\"\r\n    tt = Mid(s1.Cells(i + 1, 2), 1, 20)\r\n    Dim a As Integer\r\n    If IsError(prjPCC.NumberOfTasks) Then\r\n        a = 0\r\n    Else\r\n        a = prjPCC.NumberOfTasks\r\n    End If\r\n    Task = prjPCC.Tasks.Add(tt, a + 1)\r\n        Set tsk = prjPCC.Tasks(i - 3)\r\n        If getInd(s1.Cells(i + 2, 2)) > getInd(s1.Cells(i + 1, 2)) Then\r\n            tsk.Manual = False\r\n        Else\r\n            tsk.Manual = True\r\n        End If\r\n        dd = Mid(WeekdayName(Weekday(CDate(s1.Cells(i + 1, 4)))), 1, 3)\r\n        dat = str(s1.Cells(i + 1, 4))\r\n        ddef = dd & \" \" & dat\r\n        tsk.Start = ddef\r\n        dd = Mid(WeekdayName(Weekday(CDate(s1.Cells(i + 1, 5)))), 1, 3)\r\n        dat = str(s1.Cells(i + 1, 5))\r\n        ddef = dd & \" \" & dat\r\n        tsk.Finish = ddef\r\n        tsk.PercentComplete = str(s1.Cells(i + 1, 7) * 100) & \"%\"\r\n        tsk.ResourceNames = s1.Cells(i + 1, 6)\r\n        tsk.Text1 = s1.Cells(i + 1, 8)\r\n        tsk.Text2 = s1.Cells(i + 1, 11)\r\n        If s1.Cells(i + 1, 9) <> \"\" Then\r\n            If s1.Cells(i + 1, 9) <> \"\" Then\r\n                tsk.Predecessors = s1.Cells(i + 1, 9) & \"FS-1 day\"\r\n            End If\r\n        End If\r\n        Dim deadl As Date\r\n        deadl = Format(duedate, dateform)\r\n        tsk.deadline = deadl\r\n        tsk.OutlineLevel = getInd(s1.Cells(i + 1, 2)) + 1\r\n        i = i + 1\r\n    Wend\r\n    projApp.AddNewColumn (\"Text1\")\r\n    projApp.AddNewColumn (\"Text2\")\r\n    'Tidy up\r\n    Set projApp = Nothing\r\nnext2:\r\nEnd Sub<\/pre>\n
 <\/p>\n
El siguiente video es una demonstraci\u00f3n de como funciona el archivo Excel exportando a MS Project y a el servidor Web.<\/p>\n