Un Gantt en Excel manipulando los recursos y la curva de inversión.

Observando el rechazo masivo a usar Project para programar obras surgió esta macro. 

Las entradas son las tareas, su comienzo, su duración y su costo tanto programado como real.

La salida automática es la integración del diagrama de gantt con sus barras, la curva de inversión, la curva de avance y la interposición de los recursos en la escala del tiempo en la parte superior, y por supuesto la fecha de hoy transversal a toda la información gráfica. Todo en la misma pantalla y en simultáneo.

Pero como? es la pregunta!

Una vez escritas las actividades, y las fechas de inicio y de fin de cada una vamos a necesitar un auxiliar llamado B_Crear_Calendario que arme por nosotros el calendario hacia la derecha con un formato que sea entendible a simple vista, claro que para esto entiendo que la fecha de partida será la fecha más pequeña del programa y la máxima la fecha más lejana de todo el programa.

Luego, otro auxiliar llamado C_Crear_Barras nos ayudará a crear dentro de este calendario las barras correspondientes a las tareas pero, teniendo en cuenta que a cada tarea será asignada un recurso, al mismo tiempo en la parte superior aparecerá la gráfica de quién será el responsable de esa tarea ocupando la franja en la línea de tiempo.

Pero si pienso que también quiero una curva de avance y que no pueden convivir dos informaciones en la misma celda, la solución está en crear por medio de la macro las barras como shapes contenidas en las celdas a las que corresponda y al mismo tiempo escribir dentro de la celda el valor que le corresponda. En resumen digo que solo vamos a ver la barra, pero que está en su interior esconde el avance fraccionado.

Pero como fraccionamos ese porcentaje? Aca voy a buscar suplantar una gran mentira por mentiritas más pequeñas con alguna certezas. Es decir que en vez de dividir el precio calculado en el plazo propuesto lo que sería un avance lineal voy a proponer que puede o no haber anticipo financiero, que puedo o no haber una retención para el final de la tarea y que todo lo que ocurra post anticipo y antes de la devolución de la retención será planeado con algún criterio de rendimiento. Y es aquí donde traigo algunas variantes con el solo objetivo de intentar acercarme un poquito más a la realidad.

Módulo B_Crear_Calendario:

Option Explicit
Dim Bcle As Long
Public Function Armar_Calendario()'1) Refresco las constantes del proyecto donde Determino la Hoja del Calendario, Determinar el área del calendario, Obtengo la última fila del programa, Obtener la minima y maxima del calendario y calculo los dias de duracion.
A_Declarar_Constantes.Declarar
'2)  y desactivo las advertencias y desactivo act. Automaticas
Excel.Application.DisplayAlerts = False
Application.ScreenUpdating = False
'3) Borro todo el calendario actual
Hoja_Work.Range(Cells(1, Columna_Inicio_Calendario), Cells(Max_Row, 6500)).Delete
'4) Escribo fechas y dias en la cabezera
For Bcle = Columna_Inicio_Calendario To Periodo + Columna_Inicio_Calendario
    Hoja_Work.Cells(Fila_Year, Bcle) = Min_Fecha + (Bcle - Columna_Inicio_Calendario)
    Hoja_Work.Cells(Fila_Month, Bcle) = Min_Fecha + (Bcle - Columna_Inicio_Calendario)
    Hoja_Work.Cells(Fila_Day, Bcle) = Min_Fecha + (Bcle - Columna_Inicio_Calendario)
    Hoja_Work.Cells(Fila_Day_Letra, Bcle) = UCase(Left((Format(Min_Fecha + (Bcle - Columna_Inicio_Calendario), "ddd")), 1))
    If Hoja_Work.Cells(Fila_Day_Letra, Bcle) = "D" Then
        Hoja_Work.Cells(Fila_Day_Letra, Bcle).Font.color = -16776961
        With Hoja_Work.Range(Cells(Fila_Day_Letra, Bcle), Cells(Max_Row - 1, Bcle)).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -0.149998474074526
            .PatternTintAndShade = 0
        End With
    End If
Next
Dim Temp_Range As Range
Dim Temp_Inicio As Integer
'5) Resumo los meses
Temp_Inicio = Columna_Inicio_Calendario
For Bcle = Columna_Inicio_Calendario To Periodo + Columna_Inicio_Calendario
    If Not Format(Hoja_Work.Cells(Fila_Month, Bcle), "mm") = Format(Hoja_Work.Cells(Fila_Month, Bcle + 1), "mm") Then
        Set Temp_Range = Hoja_Work.Range(Cells(Fila_Month, Temp_Inicio), Cells(Fila_Month, Bcle))
        Temp_Range.Merge
        Temp_Inicio = Bcle + 1
    End If
Next
'6) Resumo los años
Temp_Inicio = Columna_Inicio_Calendario
For Bcle = Columna_Inicio_Calendario To Periodo + Columna_Inicio_Calendario
    If Not Year(Hoja_Work.Cells(Fila_Year, Bcle)) = Year(Hoja_Work.Cells(Fila_Year, Bcle + 1)) Then
        Set Temp_Range = Hoja_Work.Range(Cells(Fila_Year, Temp_Inicio), Cells(Fila_Year, Bcle))
        Temp_Range.Merge
        Temp_Inicio = Bcle + 1
    End If
Next
'7) Doy formato a las cuatro filas
Set Temp_Range = Hoja_Work.Range(Cells(Fila_Day, Columna_Inicio_Calendario), Cells(3, Bcle - 1))
    Temp_Range.NumberFormat = "dd"
Set Temp_Range = Hoja_Work.Range(Cells(Fila_Month, Columna_Inicio_Calendario), Cells(2, Bcle - 1))
    Temp_Range.NumberFormat = "mmmm"
Set Temp_Range = Hoja_Work.Range(Cells(Fila_Year, Columna_Inicio_Calendario), Cells(1, Bcle - 1))
    Temp_Range.NumberFormat = "yyyy"
Set Temp_Range = Hoja_Work.Range(Cells(Fila_Year, Columna_Inicio_Calendario), Cells(Fila_Day_Letra, Bcle - 1))
    Temp_Range.HorizontalAlignment = -4108
    Temp_Range.EntireColumn.AutoFit
    Temp_Range.Borders.Value = 1
'8) Doy formato al interior del calendario
Set Temp_Range = Hoja_Work.Range(Cells(Fila_Inicio_Calendario, Columna_Inicio_Calendario), Cells(Max_Row - 1, Columna_Inicio_Calendario + Periodo))
    With Temp_Range.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Temp_Range.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Temp_Range.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Temp_Range.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Temp_Range.Borders(xlInsideVertical)
        .LineStyle = xlDot
        .ColorIndex = xlAutomatic
        .TintAndShade = -0.149998474074526
        .Weight = xlThin
    End With
    With Temp_Range.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = -0.149998474074526
        .Weight = xlHairline
    End With
'09) Activo las advertencias y termino la aplicación
Excel.Application.DisplayAlerts = True
Application.ScreenUpdating = True
End
End Function

Módulo C_Crear_Barras:

Public Function Crear_Barras_Completo()
'1) Refrezco las constantes del proyecto donde Determino la Hoja del Calendario, Determino el area del calendario, Obtengo la ultima fila del programa, Obtengo la minima y maxima del calendario y calculo los dias de duracion
A_Declarar_Constantes.Declarar

'2)  y desactivo las advertencias y desactivo act. Automaticas
Excel.Application.DisplayAlerts = False
Application.ScreenUpdating = False

'3) Recorro programa y escribo barrasDim Grafico As Shape
For Each Grafico In Excel.Sheets("Gantt").Shapes
    Grafico.Delete
'    If Left(Grafico.Name, 1) = "P" Or Left(Grafico.Name, 1) = "T" Then: Grafico.Delete
Next
For Bcle = Fila_Inicio_Calendario To Max_Row - 1
    'MsgBox Hoja_Work.Cells(Bcle, Col_ID)
    'MsgBox Hoja_Work.Cells(Bcle, Col_Name)
    'MsgBox Hoja_Work.Cells(Bcle, Col_Start)
    'MsgBox Val(Hoja_Work.Cells(Bcle, Col_Dur))
   ' MsgBox Hoja_Work.Cells(Bcle, Col_Finish)
   ' MsgBox Hoja_Work.Cells(Bcle, Col_Cost)
   ' MsgBox Hoja_Work.Cells(Bcle, Col_Recurso)
    'Calculo la ubicacion de la barra
    'Dim Col_Start As Long
    Set Temp_Range = Hoja_Work.Range(Hoja_Work.Cells(Bcle, Hoja_Work.Cells(Bcle, Col_Start) - Min_Fecha + Columna_Inicio_Calendario), Hoja_Work.Cells(Bcle, Hoja_Work.Cells(Bcle, Col_Start) - Min_Fecha + Columna_Inicio_Calendario + Val(Hoja_Work.Cells(Bcle, Col_Dur))))
    Dim C_X As Double: C_X = Temp_Range.Left
    Dim C_Y As Double: C_Y = Temp_Range.Top + Temp_Range.Height * 0.1
    Dim Alto As Double: Alto = Temp_Range.Height * 0.8
    Dim Ancho As Double: Ancho = Temp_Range.Width
    Dim Texto As String: Texto = Hoja_Work.Cells(Bcle, Col_Name)
    Dim Barra_Name As String: Barra_Name = Hoja_Work.Cells(Bcle, Col_ID)
    
    If C_X = 0 Then Exit Function
    If C_Y = 0 Then Exit Function
    If Alto = 0 Then Exit Function
    If Ancho = 0 Then Exit Function
    If Texto = "" Then Exit Function
    If Barra_Name = "" Then Exit Function
    
    Barras_Gantt C_X, C_Y, Alto, Ancho, Texto, "R_" & Barra_Name
Next
End Function
Public Function Barras_Gantt(C_X As Double, C_Y As Double, Alto As Double, Ancho As Double, Texto As String, Barra_Name As String)
    Dim barra As Shape
    'Dim Typo As String
    Set barra = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, C_X, C_Y, Ancho, Alto)
    With barra
        If Left(Barra_Name, 1) = "P" Then
            .ShapeStyle = msoShapeStylePreset37
            .Name = Barra_Name
            .Fill.Solid
            .Fill.Visible = msoTrue
            .Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
            .Fill.ForeColor.TintAndShade = 0.2
            .Fill.ForeColor.Brightness = -0.35
            .Fill.Transparency = 0.2
            
            .TextFrame2.TextRange.Characters.Text = Texto
            .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .TextFrame2.VerticalAnchor = msoAnchorMiddle
            .TextFrame2.TextRange.Font.Size = 8
            .TextFrame2.TextRange.Font.Fill.Visible = msoTrue
            .TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
            .TextFrame2.TextRange.Font.Fill.ForeColor.TintAndShade = 0
            .TextFrame2.TextRange.Font.Fill.ForeColor.Brightness = 0
            .TextFrame2.TextRange.Font.Fill.Transparency = 0
            .TextFrame2.TextRange.Font.Fill.Solid
        End If
        If Left(Barra_Name, 1) = "R" Then
            .ShapeStyle = msoShapeStylePreset38
            .TextFrame2.TextRange.Characters.Text = Texto
            .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .TextFrame2.VerticalAnchor = msoAnchorMiddle
            .TextFrame2.TextRange.Font.Size = 8
            .TextFrame2.TextRange.Font.Fill.Visible = msoTrue
            .TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
            .TextFrame2.TextRange.Font.Fill.ForeColor.TintAndShade = 0
            .TextFrame2.TextRange.Font.Fill.ForeColor.Brightness = 0
            .TextFrame2.TextRange.Font.Fill.Transparency = 0
            .TextFrame2.TextRange.Font.Fill.Solid
            .Name = Barra_Name
        End If
        If Left(Barra_Name, 1) = "T" Then
            .ShapeStyle = msoShapeStylePreset1
            .TextFrame2.TextRange.Characters.Text = Texto
            .Fill.ForeColor.RGB = RGB(255, 0, 0)
            .Fill.Transparency = 0.75
            .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .TextFrame2.VerticalAnchor = msoAnchorMiddle
            .TextFrame2.TextRange.Font.Size = 10
            
            .TextFrame2.TextRange.Font.Fill.Solid
            .TextFrame2.TextRange.Font.Fill.Visible = msoTrue
            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
            .Name = Barra_Name
        End If
    End With
End Function

Módulo A_Declarar_Constantes:

Option Explicit
Public Columna_Inicio_Calendario As Integer
Public Fila_Inicio_Calendario As Integer
Public Fila_Year As Long
Public Fila_Month As Long
Public Fila_Day As Long
Public Fila_Day_Letra As Long
Public Hoja_Gantt As String
Public Hoja_Work As Worksheet
Public Min_Fecha As Date
Public Max_Fecha As Date
Public Periodo As Long
Public Max_Row As Long
Public Col_ID As Long
Public Col_Name As Long
Public Col_Start As Long
Public Col_Dur As Long
Public Col_Finish As Long
Public Col_Cost As Long
Public Col_Recurso As Long
Public Function Declarar()
Hoja_Gantt = "Gantt"
Set Hoja_Work = Excel.Sheets(Hoja_Gantt)
Columna_Inicio_Calendario = 22
Fila_Inicio_Calendario = 8
Col_ID = 1
Col_Name = 2
Col_Start = 11
Col_Dur = 12
Col_Finish = 13
Col_Cost = 6
Col_Recurso = 8
Fila_Year = Fila_Inicio_Calendario - 4
Fila_Month = Fila_Inicio_Calendario - 3
Fila_Day = Fila_Inicio_Calendario - 2
Fila_Day_Letra = Fila_Inicio_Calendario - 1
Max_Row = (Hoja_Work.UsedRange.Row) + Hoja_Work.UsedRange.Rows.Count
Dim Bcle As Long
For Bcle = Fila_Inicio_Calendario To Max_Row
    If CDate(Hoja_Work.Cells(Bcle, Col_Finish)) > 0 And CDate(Hoja_Work.Cells(Bcle, Col_Finish)) > CDate(Max_Fecha) Then Max_Fecha = Hoja_Work.Cells(Bcle, Col_Finish)
Next
Min_Fecha = Max_Fecha 'Supuesto
For Bcle = Fila_Inicio_Calendario To Max_Row
    If CDate(Hoja_Work.Cells(Bcle, Col_Start)) > 0 And CDate(Hoja_Work.Cells(Bcle, Col_Start)) < CDate(Min_Fecha) Then Min_Fecha = Hoja_Work.Cells(Bcle, Col_Start)
Next
Periodo = Max_Fecha - Min_Fecha
End Function

El Reactivo en la Hoja del Gantt:

Option Explicit

Dim Bcle As Long

Private Sub Worksheet_Change(ByVal Target As Range)

Inicio:

Dim Hoja As String: Hoja = "Gantt"

Dim Barra_Name As String

Dim Fecha_I As Date

Dim Fecha_F As Date

Dim Dias As Long

Dim barra As Shape

Dim Min_Fecha As Date

Dim Temp_Fecha As Date

Dim C_Ini As Long: Dim C_Fi As Long

Dim L_Barra As Double

Dim P_Recurso As String

'Defino columnas

Dim Colum_P_I As Long: Colum_P_I = 11

Dim Colum_P_D As Long: Colum_P_D = 12

Dim Colum_P_F As Long: Colum_P_F = 13

Dim Colum_R_I As Long: Colum_R_I = 14

Dim Colum_R_D As Long: Colum_R_D = 15

Dim Colum_R_F As Long: Colum_R_F = 16

Dim Colum_Inicio_Gantt As Long: Colum_Inicio_Gantt = 22

'Defino datos comunes

Min_Fecha = Sheets(Hoja).Cells(4, 8)

Ctrl_G.Obtener_Rango Hoja, Target.Row, 1, Barra_Name

Select Case Target.Column

Case Colum_P_I To Colum_P_F

    Barra_Name = "P_" & Barra_Name

    P_Recurso = "T_" & Excel.Sheets(Hoja).Cells(Target.Row, 1)

    Fecha_I = Sheets(Hoja).Cells(Target.Row, Colum_P_I)

    Dias = Sheets(Hoja).Cells(Target.Row, Colum_P_D)

    Fecha_F = Sheets(Hoja).Cells(Target.Row, Colum_P_F): Fecha_F = Fecha_I + Dias

    If Target.Column = Colum_P_I Then

        If Not Sheets(Hoja).Cells(Target.Row, Colum_P_F) = Fecha_F Then Sheets(Hoja).Cells(Target.Row, Colum_P_F) = Fecha_F

        Sheets(Hoja).Cells(Target.Row, Colum_P_D) = Dias

    End If

    If Target.Column = Colum_P_F Then

        Dias = Fecha_F - Fecha_I

        If Not Sheets(Hoja).Cells(Target.Row, Colum_P_D) = Dias Then Sheets(Hoja).Cells(Target.Row, Colum_P_D) = Dias

    End If

    If Target.Column = Colum_P_D Then

        If Not Sheets(Hoja).Cells(Target.Row, Colum_P_F) = Fecha_F Then Sheets(Hoja).Cells(Target.Row, Colum_P_F) = Fecha_F

        For Each barra In Sheets(Hoja).Shapes

            If barra.Name = Barra_Name Then: barra.Delete: Exit For

        Next

        'Borro la barra del recurso

        For Each barra In Sheets(Hoja).Shapes

            If barra.Name = P_Recurso Then: barra.Delete: Exit For

        Next

        If Sheets(Hoja).Cells(Target.Row, Colum_P_I) = 0 Or Sheets(Hoja).Cells(Target.Row, Colum_P_F) = 0 Then Exit Sub

        Temp_Fecha = Sheets(Hoja).Cells(Target.Row, Colum_P_F)

        C_Ini = Colum_Inicio_Gantt + (Fecha_I - Min_Fecha): C_Fi = C_Ini + Dias

        L_Barra = Sheets(Hoja).Range(Cells(Target.Row, C_Ini), Cells(Target.Row, C_Fi)).Width

        C_Fi = L_Barra

        C_Ini = Val(Excel.Sheets(Hoja).Cells(Target.Row, C_Ini).Left)

        'Ctrl_G.Barras_Gantt Val(C_Ini), Target.Top + Target.Height / 6, Val(C_Fi), Target.Height / 1.5, Excel.Sheets(Hoja).Cells(Target.Row, 2), Barra_Name

        Dim Cel_I, Cel_F As Long

        ' modifico costos en gantt

        Display_Excel.Proteger_Hoja Excel.ThisWorkbook.Name, "Gantt", False

        Sheets("Gantt").Range(Cells(Target.Row, Colum_Inicio_Gantt), Cells(Target.Row, 365)).Clear

        Display_Excel.Proteger_Hoja Excel.ThisWorkbook.Name, "Gantt", False

                Cel_I = Colum_Inicio_Gantt + (Fecha_I - Min_Fecha)

                Cel_F = Cel_I + Dias

        For Bcle = Cel_I To Cel_F

            Display_Excel.Proteger_Hoja Excel.ThisWorkbook.Name, "Gantt", False

            Cells(Target.Row, Bcle) = Cells(Target.Row, 6) / (Cel_F - Cel_I + 1)

        Next

        Formato.Format_H_Text Excel.ActiveWorkbook.Name, Hoja, Cells(Target.Row, Cel_I), Cells(Target.Row, Cel_F), 4

        'Escribo el recurso

        If Len(Excel.Sheets(Hoja).Cells(Target.Row, 8)) > 0 Then

            Cel_I = Colum_Inicio_Gantt + (Fecha_I - Min_Fecha)

            Cel_F = Cel_I + Dias

            'Verifico de no pisarlo

            Dim H_Recursos As Double: H_Recursos = Excel.Sheets("Gantt").Range(Cells(1, 1), Cells(4, 1)).Height

            Dim Cant_Max_Rec As Double: Cant_Max_Rec = 0 'se obtiene de fila 1

            For Bcle = Cel_I To Cel_F

                If Excel.Sheets(Hoja).Cells(1, Bcle) > Cant_Max_Rec Then Cant_Max_Rec = Val(Excel.Sheets(Hoja).Cells(1, Bcle))

            Next

            Dim barra_Altura As Long: barra_Altura = H_Recursos / Cant_Max_Rec

            Dim Recurso_Y As Double: Recurso_Y = 0

            Dim Recurso_Y_min As Double: Recurso_Y_min = H_Recursos - barra_Altura

            For Each barra In Sheets(Hoja).Shapes

                If Left(barra.Name, 1) = "T" Then

                    If barra.Left > C_Ini And barra.Left < (C_Ini + C_Fi) Or barra.Left + barra.Width > C_Ini And barra.Left + barra.Width < (C_Ini + C_Fi) Then

                        barra.Height = barra_Altura

                        If barra.Height + barra.Top >= Recurso_Y Then Recurso_Y = barra.Height + barra.Top

                        If barra.Height < Recurso_Y_min Then Recurso_Y_min = barra.Height

                    End If

                End If

            Next

    MsgBox Recurso_Y_min & "-" & Recurso_Y

            Display_Excel.Proteger_Hoja Excel.ThisWorkbook.Name, "Gantt", False

            'Ctrl_G.Barras_Gantt Val(C_Ini), ((Temp_N - 1) * barra_Altura), Val(C_Fi), Val(barra_Altura), Excel.Sheets(Hoja).Cells(Target.Row, 8), P_Recurso

            'Ctrl_G.Barras_Gantt Val(C_Ini), Recurso_Y, Val(C_Fi), Val(barra_Altura), Excel.Sheets(Hoja).Cells(Target.Row, 8), P_Recurso

        End If

    End If

Case Colum_R_I To Colum_R_F

    Barra_Name = "R_" & Barra_Name

    Fecha_I = Sheets(Hoja).Cells(Target.Row, Colum_R_I)

    Dias = Sheets(Hoja).Cells(Target.Row, Colum_R_D)

    Fecha_F = Sheets(Hoja).Cells(Target.Row, Colum_R_F): Fecha_F = Fecha_I + Dias

    If Target.Column = Colum_R_I Then

        If Not Sheets(Hoja).Cells(Target.Row, Colum_R_F) = Fecha_F Then Sheets(Hoja).Cells(Target.Row, Colum_R_F) = Fecha_F

        Sheets(Hoja).Cells(Target.Row, Colum_R_D) = Dias

    End If

    If Target.Column = Colum_R_F Then

        Dias = Fecha_F - Fecha_I

        If Not Sheets(Hoja).Cells(Target.Row, Colum_R_D) = Dias Then Sheets(Hoja).Cells(Target.Row, Colum_R_D) = Dias

    End If

    If Target.Column = Colum_R_D Then

        If Not Sheets(Hoja).Cells(Target.Row, Colum_R_F) = Fecha_F Then Sheets(Hoja).Cells(Target.Row, Colum_R_F) = Fecha_F

        For Each barra In Sheets(Hoja).Shapes

            If barra.Name = Barra_Name Then: barra.Delete: Exit For

        Next

        If Sheets(Hoja).Cells(Target.Row, Colum_R_I) = 0 Or Sheets(Hoja).Cells(Target.Row, Colum_R_F) = 0 Then Exit Sub

        Temp_Fecha = Sheets(Hoja).Cells(Target.Row, Colum_R_F)

        C_Ini = Colum_Inicio_Gantt + (Fecha_I - Min_Fecha): C_Fi = C_Ini + Dias

        L_Barra = Sheets(Hoja).Range(Cells(Target.Row, C_Ini), Cells(Target.Row, C_Fi)).Width

        C_Fi = L_Barra

        C_Ini = Val(Excel.Sheets(Hoja).Cells(Target.Row, C_Ini).Left)

        'Ctrl_G.Barras_Gantt Val(C_Ini), Target.Top + Target.Height / 4, Val(C_Fi), Target.Height / 2, Excel.Sheets(Hoja).Cells(Target.Row, 2), Barra_Name

    End If

End Select

End Sub

Public Sub Ubicar_Avance()

Display_Excel.Proteger_Hoja Excel.ThisWorkbook.Name, "Gantt", False

Dim Grafico As Shape

'Dim Titulo As Range

Dim T As Double

Dim L As Double

Dim H As Double

Dim W As Double

For Each Grafico In Excel.Sheets("Gantt").Shapes

With Excel.Sheets("Gantt")

Select Case Grafico.Name

Case "G_Desagregado":   T = .Cells(5, 1).Top

                        L = .Cells(5, 1).Left

                        H = .Cells(6, 3).Top - Grafico.Top

                        W = .Cells(6, 3).Left - Grafico.Left

                        Grafico.Locked = True

Case "G_Separador":     T = .Cells(1, 21).Top

                        L = .Cells(1, 21).Left

                        H = .Cells(43, 22).Top - Grafico.Top

                        W = .Cells(43, 22).Left - Grafico.Left

                        Grafico.Locked = True

Case "G_Licitacion":    T = .Cells(5, 3).Top

                        L = .Cells(5, 3).Left

                        H = .Cells(6, 8).Top - Grafico.Top

                        W = .Cells(6, 8).Left - Grafico.Left

                        Grafico.Locked = True

Case "G_Titulo":        T = .Cells(1, 1).Top

                        L = .Cells(1, 1).Left

                        H = .Cells(3, 21).Top - Grafico.Top

                        W = .Cells(3, 21).Left - Grafico.Left

                        Grafico.Locked = True

Case "G_Prog":          T = .Cells(5, 8).Top

                        L = .Cells(5, 8).Left

                        H = .Cells(6, 14).Top - Grafico.Top

                        W = .Cells(6, 14).Left - Grafico.Left

                        Grafico.Locked = True

Case "G_Real":          T = .Cells(5, 14).Top

                        L = .Cells(5, 14).Left

                        H = .Cells(6, 21).Top - Grafico.Top

                        W = .Cells(6, 21).Left - Grafico.Left

                        Grafico.Locked = True

End Select

End With

    If Grafico.Name = "Deagregado" Then

        Grafico.Top = Excel.Sheets("Gantt").Cells(5, 1).Top

        Grafico.Left = Excel.Sheets("Gantt").Cells(5, 1).Left

        Grafico.Height = Excel.Sheets("Gantt").Cells(6, 1).Top - Grafico.Top

        Grafico.Width = Excel.Sheets("Gantt").Cells(6, 3).Left - Grafico.Left

        Grafico.Locked = False

    End If

    If Grafico.Name = "G_Titulo_Gantt" Then

        Grafico.Top = Excel.Sheets("Gantt").Cells(1, 1).Top

        Grafico.Left = Excel.Sheets("Gantt").Cells(6, 22).Left

        Grafico.Height = Excel.Sheets("Gantt").Cells(5, 1).Top - Grafico.Top

        Grafico.Width = Excel.Sheets("Gantt").Cells(43, 182).Left - Grafico.Left

        Grafico.Locked = True

    End If

    If Grafico.Name = "G_Avances" Then

        Grafico.Top = Excel.Sheets("Gantt").Cells(6, 1).Top

        Grafico.Left = Excel.Sheets("Gantt").Cells(6, 22).Left

        Grafico.Height = Excel.Sheets("Gantt").Cells(43, 1).Top - Grafico.Top

        Grafico.Width = Excel.Sheets("Gantt").Cells(43, 182).Left - Grafico.Left

        Grafico.Locked = True

    End If

Next

Display_Excel.Proteger_Hoja Excel.ThisWorkbook.Name, "Gantt", True

End Sub

Public Function Obtener_Max_Min_Date_Partes()

Dim Temp_Range As Variant

Dim Bcle As Long

Dim Min_Date As Date

Dim Max_Dateb As Date

Dim Max_Row As Long

Ctrl_G.Obtener_Ultima_fila "Partes $", Max_Row

Ctrl_G.Capturar_Mtz_Total "Partes $", Temp_Range, 2, 2, 2, Max_Row

For Bcle = 1 To UBound(Temp_Range)

If Bcle = 1 Then Max_Dateb = Temp_Range(Bcle, 1)

If Bcle = 1 Then Min_Date = Temp_Range(Bcle, 1)

If Temp_Range(Bcle, 1) > Max_Dateb Then: Max_Dateb = Temp_Range(Bcle, 1)

If Temp_Range(Bcle, 1) < Min_Date And Temp_Range(Bcle, 1) > 0 Then: Min_Date = Temp_Range(Bcle, 1)

Next

Ctrl_G.Obtener_Ultima_fila "Gantt", Max_Row

Ctrl_G.Capturar_Mtz_Total "Gantt", Temp_Range, 6, 6, 5, Max_Row

For Bcle = 1 To UBound(Temp_Range)

If Temp_Range(Bcle, 1) < Min_Date And Temp_Range(Bcle, 1) > 0 Then: Min_Date = Temp_Range(Bcle, 1)

Next

Ctrl_G.Capturar_Mtz_Total "Gantt", Temp_Range, 8, 8, 5, Max_Row

For Bcle = 1 To UBound(Temp_Range)

If Temp_Range(Bcle, 1) > Max_Dateb Then: Max_Dateb = Temp_Range(Bcle, 1)

Next

Ctrl_G.Capturar_Mtz_Total "Gantt", Temp_Range, 9, 9, 5, Max_Row

For Bcle = 1 To UBound(Temp_Range)

If Temp_Range(Bcle, 1) < Min_Date And Temp_Range(Bcle, 1) > 0 Then: Min_Date = Temp_Range(Bcle, 1)

Next

Ctrl_G.Capturar_Mtz_Total "Gantt", Temp_Range, 11, 11, 5, Max_Row

For Bcle = 1 To UBound(Temp_Range)

If Temp_Range(Bcle, 1) > Max_Dateb Then: Max_Dateb = Temp_Range(Bcle, 1)

Next

Sheets("Gantt").Cells(1, 5) = Min_Date

Sheets("Gantt").Cells(2, 5) = Max_Dateb

Armar_Calendario

End Function

Si te interesa dale al boton G+, comenta, participa...

Y escribime para enviarte el ejemplo!