Cómputos de Instalaciones Eléctricas


Translate

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!

10 comentarios:

  1. amigo que buen ejemplo, envíame por fa el archivo. ing.orlando.gomez@hotmail.com

    ResponderEliminar
    Respuestas
    1. Orlando, muchas gracias por interesarte. A tu correo envíe via dropbox un link de descarga.

      Eliminar
  2. Me ha parecido sumamente interesante la macro a la cual haces referencia. Es cierto en muchas personas huyen de programas sofisticados, pero tambien les huyen a la ejecución de macros y elaboración de los sistemas. Asi que el aporte dado es sumamente interesante. Saludos. Enviame el ejemplo en cuestión y te dare mis impresiones al respecto.

    ResponderEliminar
    Respuestas
    1. Manuel, perdón la demora y muchas gracias por interesarte. Por favor envíame un mensaje con tu correo para poder compartirte un link de descarga.

      Eliminar
  3. Hola muy buen ejemplo, exelente dar opciones a quienes se rehúsan a usar project, felicitaciones.
    Te dejo mi correo para que me compartas el ejemplo bastianarteaga13@gmail.com saludos.

    ResponderEliminar
    Respuestas
    1. Muchas gracias por interesarte, te mande un enlace via dropbox para que puedas descargarlo. Es muy cierto lo que indicas acerca de Project, coincido con que la palabra correcta es "Rehúsan".

      Eliminar
  4. Muy buen aporte, te mando mi email por si me puedes enviar el ejemplo y ver y apoyarte en la idea. Saludos. tielax@hotmail.com

    ResponderEliminar
    Respuestas
    1. Saludos, te envíe un enlace via dropbox, sería mas que bienvenido tu apoyo.

      Eliminar
  5. Buen día, me pareció muy interesante tu artículo. Por favor envíame el link de descarga a mi correo rafaelprado1511@gmail.com ; Muchas gracias!, Saludos

    ResponderEliminar