Диаграмма ганта excel vba - Word и Excel - помощь в работе с программами

Доброго дня, Планетяне!
Возникла необходимость в автоматизации создания линейных графиков сотрудниками компании, в которой я работаю.
Сочинил вот макрос. Он работает и довольно универсален. Присутствуют проверки и диалоговые окна. Делюсь на добровольной основе.

Работает по принципу, описанному в приёмах, только не через УФ, а путём обычного «закрашивания». Это влечёт за собой массу плюсов. Разумеется, можно преобразовать условное форматирование в реальное (как, например, тут), но это долго и не решает прочих проблем (как, например, постоянное редактирование условий УФ при изменении данных).

Код макроса

Буду рад замечаниям и советам от опытных VBA’шников по улучшению/ускорению кода

Изменено: Jack Famous — 06.09.2017 11:23:39

Источник

Скачать Диаграмма Гантта авто InExSu 2020 01.XLAM

Скачать Диаграмма Ганнта Данные

Option Explicit
'Модуль универсальных процедур. Часть кода. Гант?
' для сортировки
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Type QuickStack
    Low As Long
    High As Long
End Type
 
Public Function Строка_Крайняя(ws As Worksheet) As Long    ' тестом Покрыто опосредованно
' Найти последняя строку  с данными, непустую
    On Error Resume Next
    Строка_Крайняя = _
    ws.Cells.Find(What:="*", SearchOrder:=xlByRows, _
                  SearchDirection:=xlPrevious).Row
    If Строка_Крайняя = 0 Then Строка_Крайняя = 1
End Function
 
Public Function Столбец_Крайний(ws As Worksheet) As Long    ' тестом Покрыто опосредованно
' Найти последний столбец с данными, непустой
    On Error Resume Next
    Столбец_Крайний = _
    ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
                  SearchDirection:=xlPrevious).Column
    If Столбец_Крайний = 0 Then Столбец_Крайний = 1
End Function
 
Public Function Ячейка_Найти(ByVal rng As Range, ByVal str As String) As Range
' ячейку найти
    Dim rng_Found As Range
    Set rng_Found = Диап_Усечь(rng).Find(str)
 
    If Not rng_Found Is Nothing Then _
       Set Ячейка_Найти = rng_Found
 
End Function
 
Public Function Диап_Усечь(rng As Range) _
       As Range    ' тестом Покрыто опосредованно
 
    Set Диап_Усечь = Application.Intersect( _
                     Диап_Реальный(rng.Parent), rng)
 
End Function
 
Public Function Диап_Реальный(ws As Worksheet) _
       As Range    ' тестом Покрыто опосредованно
' диапазон реальный без висячих ячеек, строк и столбцов
    If ws Is Nothing Then Set ws = ActiveSheet
 
    With ws
        Set Диап_Реальный = .Range(.Cells(.UsedRange.Row, .UsedRange.Column), _
                                   .Cells(Строка_Крайняя(ws), Столбец_Крайний(ws)))
    End With
 
End Function
 
 
 
Sub Example()
    Dim x()
    x = Array(9, 3, 8, 1, 6)
    d1_Сортировка x()
End Sub
 
Private Sub d1_Сортировка(ByRef x())
    Dim v, u&, d&, f%
    If IsArray(x) Then
        f = LBound(x): d = f
        For u = f + 1 To UBound(x)
            If x(u) < x(d) Then
                v = x(d)
                x(d) = x(u)
                x(u) = v
                u = d - 1
                d = u - 1
                If u < f Then d = u
                u = f
            End If
            d = d + 1
        Next
    End If
End Sub
 
Sub dX_Сортировка_test()
    Dim d2() As Variant
    d2 = Selection
    dX_Сортировка_Текст_Числа d2, 1
End Sub
 
Public Function dX_Сортировка_Текст_Числа(SortArray() As Variant, _
                                          iCol As Long) As Variant()
' сортировка массива по столбцу (числа текст)
' в Начал модуля
'Private Declare Function GetTickCount Lib "kernel32" () As Long
'Private Type QuickStack
'    Low As Long
'    High As Long
'End Type
 
    Dim i As Long, j As Long, lb As Long, ub As Long, stackpos As Long, ppos As Long, _
        pivot As Variant, swp As Variant
 
    Dim stack() As QuickStack
    ReDim stack(1 To 64)
 
    stackpos = 1
 
    stack(1).Low = LBound(SortArray)
    stack(1).High = UBound(SortArray)
 
    Do
        'Взять границы lb и ub текущего массива из стека.
        lb = stack(stackpos).Low
        ub = stack(stackpos).High
        stackpos = stackpos - 1
        Do
            'Шаг 1. Разделение по элементу pivot
            ppos = (lb + ub)  2
            i = lb: j = ub: pivot = SortArray(ppos, iCol)
            Do
                While SortArray(i, iCol) < pivot: i = i + 1: Wend
                While pivot < SortArray(j, iCol): j = j - 1: Wend
                If i <= j Then
                    swp = SortArray(i, iCol)
                    SortArray(i, iCol) = SortArray(j, iCol)
                    SortArray(j, iCol) = swp
                    i = i + 1
                    j = j - 1
                End If
            Loop While i <= j
 
            'Сейчас указатель i указывает на Начал правого подмассива,
            'j - на конец левого lb ? j ? i ? ub.
            'Возможен случай, когда указатель i или j ТелеПортит за границу массива
            'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub
 
            If i < ppos Then    'правая часть больше
                If i < ub Then
                    stackpos = stackpos + 1
                    'If stackpos > UBound(stack) Then ReDim Preserve stack(1 To UBound(stack) + 32)
                    If stackpos > UBound(stack) Then ReDim Preserve stack(1 To UBound(stack) * 2)
                    stack(stackpos).Low = i
                    stack(stackpos).High = ub
                End If
                ub = j    'следующая итерация разделения будет работать с левой частью
            Else
                If j > lb Then
                    stackpos = stackpos + 1
                    If stackpos > UBound(stack) Then ReDim Preserve stack(1 To UBound(stack) * 2)
                    stack(stackpos).Low = lb
                    stack(stackpos).High = j
                End If
                lb = i
            End If
        Loop While lb < ub
    Loop While stackpos
End Function
 
Public Function d1_Сортировка_Текст_Числа(SortArray() As Variant) As Variant
' сортировка одномерного массива по столбцу (числа текст)
' в Начал модуля
'Private Declare Function GetTickCount Lib "kernel32" () As Long
'Private Type QuickStack
'    Low As Long
'    High As Long
'End Type
 
    Dim i As Long, j As Long, lb As Long, ub As Long, stackpos As Long, ppos As Long, _
        pivot As Variant, swp As Variant
 
    Dim stack() As QuickStack
    ReDim stack(1 To 64)
 
    stackpos = 1
 
    stack(1).Low = LBound(SortArray)
    stack(1).High = UBound(SortArray)
 
    Do
        'Взять границы lb и ub текущего массива из стека.
        lb = stack(stackpos).Low
        ub = stack(stackpos).High
        stackpos = stackpos - 1
        Do
            'Шаг 1. Разделение по элементу pivot
            ppos = (lb + ub)  2
            i = lb: j = ub: pivot = SortArray(ppos)
            Do
                While SortArray(i) < pivot: i = i + 1: Wend
                While pivot < SortArray(j): j = j - 1: Wend
                If i <= j Then
                    swp = SortArray(i)
                    SortArray(i) = SortArray(j)
                    SortArray(j) = swp
                    i = i + 1
                    j = j - 1
                End If
            Loop While i <= j
 
            'Сейчас указатель i указывает на Начал правого подмассива,
            'j - на конец левого lb ? j ? i ? ub.
            'Возможен случай, когда указатель i или j ТелеПортит за границу массива
            'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub
 
            If i < ppos Then    'правая часть больше
                If i < ub Then
                    stackpos = stackpos + 1
                    'If stackpos > UBound(stack) Then ReDim Preserve stack(1 To UBound(stack) + 32)
                    If stackpos > UBound(stack) Then ReDim Preserve stack(1 To UBound(stack) * 2)
                    stack(stackpos).Low = i
                    stack(stackpos).High = ub
                End If
                ub = j    'следующая итерация разделения будет работать с левой частью
            Else
                If j > lb Then
                    stackpos = stackpos + 1
                    If stackpos > UBound(stack) Then ReDim Preserve stack(1 To UBound(stack) * 2)
                    stack(stackpos).Low = lb
                    stack(stackpos).High = j
                End If
                lb = i
            End If
        Loop While lb < ub
    Loop While stackpos
End Function
 
Public Function Строк_в_Массиве(dX() As Variant) _
       As Long    ' Тестом Покрыта
    Dim DimX As Long
    DimX = Размерность(dX)
 
    Строк_в_Массиве = _
    UBound(dX, DimX) - _
                      LBound(dX, DimX) + 1
 
End Function
 
Public Function Размерность(dX() As Variant) As Long
'возвращает dimX Колво измерений массива
    Dim i As Long, x As Long
 
    On Error GoTo err_Hand        ' увеличиваем i до ошибки попытки получить UBound по данному измерению
 
    Do: i = i + 1
        x = UBound(dX, i)
    Loop
 
err_Hand:
    Размерность = i - 1
End Function
 
Public Function ТелеПорт(Optional ByVal msg As Variant, Optional Оповещение As Boolean) As Variant
' тестом Покрыта
' Пользователь не совершил ожидаемых действий
 
    If Оповещение Then
        If msg = "" Then msg = " "
        MsgBox msg, vbCritical, "ТелеПорт!"
    End If
 
    End    ' =>
End Function
 
Public Function Столбцы_с_Датами_Удалить(ws As Worksheet, Optional ByVal msg As Variant) _
       As Variant    ' тестом Покрыто
 
    On Error Resume Next    'Ячейка_с_Датой_Правая может _
                            быть Nothing
 
    Столбцы_Удалить ws, _
                    Столбец_с_Датой_Левый(ws), _
                    Ячейка_с_Датой_Правая(ws).Column
End Function
 
Public Function Столбцы_Удалить(ws As Worksheet, ByVal Col_Left As Long, _
                                ByVal Col_Right As Long) _
                                As Variant    ' тестом Покрыто опосредованно
' столбцы удалить
    If Col_Left * Col_Right > 0 Then
        With ws
            .Range(.Columns(Col_Left), .Columns(Col_Right)). _
                    EntireColumn.Delete
        End With
    End If
End Function
 
Public Function Столбец_с_Датой_Левый(ws As Worksheet) _
       As Long    ' тестом Покрыто
' Столбец, содержащий первую дату, искать
' вправо от Ячейка_с_Датой_Правая по строке
' Важно!:  найти столбец в котором ячейка с датой одна
 
    If Ячейка_с_Датой_Правая(ws) Is Nothing Then
 
        Столбец_с_Датой_Левый = 0
 
    Else
 
        Столбец_с_Датой_Левый = _
        Столбец_без_Даты(Ячейка_с_Датой_Правая(ws)) + 1
 
    End If
End Function
 
Public Function Столбец_без_Даты(Cell_w_Date As Range) _
       As Long    ' тестом Покрыто
 
' получив ячейку с датой иду влево, пока даты не кончатся
 
' Набор столбцов на листе минимальный
' 1 Столбец = Текст
' 2 Столбец = Дата начала
' 3 Столбец = Дата окончания
' 4 Столбец = 1ый столбец диаграммы
 
    If Cell_w_Date.Column > 4 Then
 
        Dim iRow As Long, iCol As Long
        iRow = Cell_w_Date.Row
        iCol = Cell_w_Date.Column
 
        Dim ws As Worksheet: Set ws = Cell_w_Date.Parent
 
        Dim x As Long
        For x = 1 To Cell_w_Date.Column - 1
 
            If IsDate(ws.Cells(iRow, iCol - x)) = False Then
 
                Столбец_без_Даты = iCol - x
 
                Exit Function
 
            End If
        Next
    End If
End Function
 
Public Function Ячейка_с_Датой_Правая(ws As Worksheet) _
       As Range    ' тестом Покрыто
 
' Ячейку, содержащую дату, искать сверху вниз влево
' Важно!:  найти столбец в котором ячейка с датой одна
 
    Dim Row_End As Long: Row_End = Строка_Крайняя(ws)
    Dim Col_Right As Long: Col_Right = Столбец_Крайний(ws)
 
    Dim y As Long, x As Long
    For x = Col_Right To 1 Step -1    ' справа налево
        For y = 1 To Row_End Step 1
 
            With ws
                If bDebug Then .Cells(y, x).Select
 
                If IsDate(.Cells(y, x)) And _
                   в_Столбце_Дата_Одна(ws, x) Then
 
                    Set Ячейка_с_Датой_Правая = .Cells(y, x)
 
                    Exit Function
                End If
            End With
        Next
    Next
End Function
 
Public Function в_Столбце_Дата_Одна(ws As Worksheet, ByVal iCol As Long) _
       As Boolean    ' тестом Покрыто опосредованно
 
    Dim rng As Range
    With ws
        Set rng = Диап_Усечь(ws.Columns(iCol))
    End With
 
    Dim eL As Range, iCount As Long
    For Each eL In rng
        If IsDate(eL.Value) Then _
           iCount = iCount + 1
        If iCount > 1 Then _
           Exit For
    Next
 
    If iCount = 1 Then _
       в_Столбце_Дата_Одна = True
 
End Function

Источник

Диаграмму Ганта эффективно использовать в анализе планирования и управления проектов. Этот инструмент визуализации данных календарного планирования приставляет собой график работ или выполнения задач, достижения поставленных целей. Рассмотрим, как сделать автоматизированный шаблон диаграммы Ганта с переключением периодичности временных интервалов на календарном графике: по дням и по неделям. А в конце статьи можно скачать готовый пример.

Как сделать диаграмму Ганта в Excel – пошаговое руководство

Переименуйте название рабочего листа Excel «Лист1» в имя «Gantt». После на этом же листе создайте таблицу с исходными данными точно такую же как показано ниже на рисунке, с таким же расположением всех ячеек на листе:

Важно!!! Чтобы у Вас все адреса заполненных ячеек листа полностью совпадали с исходной представленной на рисунке.

С помощью маркера в нижнем правом углу курсора Excel заполните диапазон ячеек G1:O1 чередующимися датами от 09.09.2022 по 17.09.2022:

Подготовка исходных данных закончена переходим непосредственно к построению диаграммы Ганта на календаре.

Как построить календарь планов с диаграммой Ганта по таблице Excel

Заполните диапазон ячеек G4:O16 на листе «Gantt» одной и той же формулой:

Теперь выделите диапазон ячеек G4:O16 чтобы присвоить ему условное форматирование:

Как видно на рисунке правило форматирования применяется для ячеек с текстовым значением «Достигнута», которое возвращают формулы в диапазоне G4:O16. Для эстетики снова используем 2 цвета заливки. Важно также отметить что на вкладке «Число» используя опцию «(все форматы)» задаем свой пользовательский формат из трех точек с запетой «;;;» — это позволит скрыть текстовое содержимое в ячейках. Получаем результат:

Перейдите на любую ячейку в диапазоне G4:O16 и откройте «Диспетчер правил условного форматирования». Для этого используйте меню «ГЛАВНАЯ»-«Условное форматирование»-«Управление правилами». Воспользовавшись кнопкой «Создать правило» создайте еще 2 правила для значений «В процессе» (желтый цвет) и «В ожидании» (красный цвет):

Теперь создадим курсор для выделения дат на графике – это сделает анализ по графику Ганта более удобным. Снова перейдите на любую ячейку в диапазоне G4:O16 и в диспетчере правил условного форматирования создайте новое правило, но уже с формулой =G$1=$F$1 и другими настройками формата ячеек:

Обратите внимание! Правило курсора должно быть в самом нижнем слое. Для управления порядком расположения правил форматирования используйте соответственные кнопки «Вверх» и «Вниз» в диспетчере. В результате получаем диаграмму Ганта с курсором выделения дат, которые указываются в ячейке F1:

Далее оформляем дизайн шапки таблицы в диапазоне B3:F3 используя градиентную заливку ячеек из двух цветов:

А также следует изменить цвет шрифта на белый в заголовках столбцов таблицы.

Как сделать управление диаграммой Ганта в Excel

Теперь в диаграмме Ганта сделаем интерактивные элементы управления из выпадающих списков. Начнем с простого. Перейдите курсором Excel на ячейку C1 чтобы в ней сделать первый выпадающий список:

В параметрах для поля ввода «Источник:» указываем два слова разделенных точкой с запятой «Дни;Недели», нажимаем ОК и выпадающий список из двух значений – ГОТОВ!

Второй выпадающий список будет более сложным. Перед его созданием сначала создадим именной диапазон с именем «Список_дат» и формулой:

Данное имя будет автоматически подгружать в себя все даты, находящиеся в первой строке листа начиная от ячейки G1. А теперь мы используем ссылку на это же имя (=Список_дат) в качестве источника для второго выпадающего списка в ячейке F1:

Теперь наш курсор для выделения дат – интерактивный и его перемещение по диаграмме Ганта управляется с помощью выпадающего списка в ячейке F1.

Пришел тот долгожданный момент, когда с помощью VBA-макроса мы будем делать магию для оживления диаграммы Ганта. Откройте редактор макросов Visual Basic нажав комбинацию клавиш ALT+F11 и создайте в нем новый модуль с кодом VBA-программы:

Полная версия кода макроса на языке программирования VBA:

Option ExplicitSub Refresh_Data()

Application.ScreenUpdating =

FalseDim sh As Worksheet
Set sh = ThisWorkbook.Sheets(«Gantt»)Dim i As Long

sh.Range(

«G3:XFD3»).UnMerge
sh.Range(«G1:XFD3»).Clear
sh.Range(«G1:XFD3»).Orientation = 0Dim lc, lr As IntegerFor i = Application.WorksheetFunction.Min(sh.Range(«C:C»)) To Application.WorksheetFunction.Max(sh.Range(«D:D»))
    If sh.Range(«G1»).Value = «» Then
        sh.Range(«G1»).Value = iElse
        lc = sh.Range(«XFD1»).End(xlToLeft).Column
        sh.Cells(1, lc + 1).Value = i
    End If
Next i

lc = sh.Range(

«XFD1»).End(xlToLeft).Column
lr = sh.Range(«B» & Application.Rows.Count).End(xlUp).RowIf sh.Range(«C1»).Value = «Äíè» Then
   sh.Range(«G3»).Value = «=G1»
   sh.Range(«G3», sh.Cells(3, lc)).FillRight

   sh.Range(

«E3»).Copy
   sh.Range(«G3», sh.Cells(3, lc)).PasteSpecial xlPasteFormats
   sh.Range(«G3», sh.Cells(3, lc)).NumberFormat = «D-MMM»
   sh.Range(«G3», sh.Cells(3, lc)).Orientation = 90
   sh.Range(«G3», sh.Cells(3, lc)).EntireColumn.ColumnWidth = 2.5ElseFor i = 7 To lc Step 7
        sh.Cells(3, i).Value = «Íåäåëÿ-« & i / 7
        sh.Range(«E3»).Copy
        sh.Range(sh.Cells(3, i), sh.Cells(3, i + 6)).PasteSpecial xlPasteFormats
        sh.Range(sh.Cells(3, i), sh.Cells(3, i + 6)).EntireColumn.ColumnWidth = 0.8
        sh.Range(sh.Cells(3, i), sh.Cells(3, i + 6)).Merge
        sh.Range(sh.Cells(3, i), sh.Cells(3, i + 6)).HorizontalAlignment = xlCenter
        sh.Range(sh.Cells(3, i), sh.Cells(3, i + 6)).VerticalAlignment = xlCenter
   Next i
      lc = sh.Range(«XFD3»).End(xlToLeft).Column + 6
End If

sh.Range(

«G1:XFD1»).NumberFormat = «D-MMM-YY»
sh.Range(«G1:XFD1»).Font.Color = VBA.vbWhite

sh.Range(

«H4:XFD» & Application.Rows.Count).Clear
sh.Range(«G5:G» & Application.Rows.Count).Clear

sh.Range(

«A» & lr + 1, «A» & Application.Rows.Count).EntireRow.Clear
sh.Range(«G1:XFD3»).Locked = True
sh.Range(«G1:XFD3»).FormulaHidden = True

sh.Range(

«G4:G» & sh.Range(«B» & Application.Rows.Count).End(xlUp).Row).FillDown
sh.Range(«G4», sh.Cells(lr, lc)).FillRightWith sh.Range(«B3», sh.Cells(lr, lc))
    .Borders(xlEdgeBottom).LineStyle = xlDouble
    .Borders(xlEdgeBottom).Color = vbBlack

    .Borders(xlEdgeLeft).LineStyle = xlDouble
    .Borders(xlEdgeLeft).Color = vbBlack

    .Borders(xlEdgeRight).LineStyle = xlDouble
    .Borders(xlEdgeRight).Color = vbBlack

    .Borders(xlEdgeTop).LineStyle = xlDouble
    .Borders(xlEdgeTop).Color = vbBlack

End With

sh.Range(

«B4», sh.Cells(lr — 1, 6)).Select
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range(«C1»).SelectEnd Sub

Чтобы воспользоваться макросом нам потребуется новый (3-тий) элемент управления диаграммой Ганта. Ним послужит простая небольшая картинка в виде кнопки с иконкой «Обновить». Копируем картинку из любого источника и вставляем прямо на лист Excel. А затем подключаем к ней наш макрос Refresh_Data:

Нажимаем на кнопку и наслаждаемся «магией» автоматизации работы в Excel с помощью макросов:

Как говорят французы «Ву а ля»!

Переключение дней и неделей для диаграммы Ганта на календаре планов

Дальше магия продолжается. Возникает вопрос зачем нам нужен был первый интерактивный элемент управления графиком Ганта – выпадающий список? Все просто необходимо создать еще один макрос, но на этот раз не в модуле, а в листе. Возвращаемся в редактор макросов ALT+F11 и в нем открываем лист «Gantt» для ввода нового кода макроса:

Код макроса для вызова с листа Excel:

Option ExplicitPrivate Sub Worksheet_Change(ByVal Target As Range)If Target.Row = 1 Then
    If Target.Column = 3 Then
        Call Refresh_Data
    End If
End If
End Sub

Протестируем второй макрос воспользовавшись первым выпадающим списком для переключения со значения «Дни» на значение «Недели»:

Второй макрос используется только для вызова первого при обновлении значения в ячейке C1 – где и находится первый выпадающий список.

Скачать шаблон диаграммы Ганта в Excel

Здесь описаны еще не все возможности первого макроса. Например, при заполнении таблицы новыми значениями и после нажатия на кнопку обновить таблица автоматически охватывает новый диапазон значений и добавляет их на график. Таким образом диаграмма Ганта автоматически расширяема и может быть использована в качестве шаблона готового к полноценной работе с новыми пользователями.

Источник

Презентация 12: VBA создание диаграммы Ганта

Канал видеоролика: Макросы Excel (VBA)

Обложка видеоролика:

Смотреть видео:

С этим видео смотрят следующие ролики:

Презентация 11: Завершение макросов для счета-фактуры. Сохранение pdf и создание гиперссылки.

Макросы Excel (VBA)

Презентация 16: VBA -создание игры » морской бой». Часть 2 — расстановка своих кораблей.

Макросы Excel (VBA)

Презентация 18:VBA — создание игры морской бой в Excel. Часть 4: автомат. расстановка кораблей.

Макросы Excel (VBA)

Создание сводной таблицы и кольцевой диаграммы

Учим MS Excel

Как построить сводную таблицу? / Создание сводной таблицы в Excel: пошаговая инструкция

Академия Excel Дмитрия Якушева

Урок №1. Создание Google Sheets с нуля! / Как форматировать Google Таблицы?

Академия Excel Дмитрия Якушева

Диаграммы в Excel. 5 Советов

Андрей Сухов: Excel Master — функции, трюки, примеры

Поделитесь этим видео с друзьями:

28.10.2021 13:47

Комментарии

Написать комментарий

Нет комментариев. Ваш будет первым!

Ваше имя:

Загрузка…

Источник

I made an excel gantt chart with the help of VBA. It is my first VBA project and I did my best to make it clean and organized however I think a lot of optimizations could be done.

I would like to ask you guys if you could take a look at some parts of my code that I have identified as the slowest and tell me if there is a better way : (Screenupdate, calculationautomatic, events, animation are all off and all my variables are declared as public and calculated in an other module)

The overall macro runs in 1s. I know it isn’t that long but it is called everytime a change is manually made on the sheet. So I’d like to bring it down as much as possible.

Macro 1 takes about 0.2s in a 1s overall macro

Sub emptycells ()
' 
' This macro empty the cells after finding some text in a row

For i = 1 To X

If IsEmpty(Cells(line + i, col1)) = False Then

coltext = WorksheetFunction.Match(Cells(line + i, col1), Range(Cells(line + i, col2), Cells(line + i, col3)), 0)
Dim rngcelltext as Range
Set rngcelltext = Cells(line + i, coltext)
Range(rngcelltext, rngcelltext.End(xlToRight)).ClearContents

End If

Next i

End Sub

Macro 2 takes about 0.25s in a 1s overall macro
Top line is the one added by this macro

Sub addweeknb()
'
' Weekline is the line N° of the second line in the picture, colweek1 is the first column of that line, rngweek is the whole line
' This macro add a line with week number on top of the time line

For i = firstweek To lastweek

numcol1 = WorksheetFunction.Match(i, rngweek, 1) 'find the column nb 
nbcol = WorksheetFunction.CountIf(rngweek, i)
Set rngweek_i = Range(Cells(weekline, colweek1 + numcol1 - nbcol), Cells(weekline, colweek1 + numcol1 - 1))
    With rngweek_i
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
        With rngsemi.Font
        .Name = "Calibri"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    rngweek_i.Merge
    rngweek_i.Font.Bold = True
    rngweek_i = i

Next i

End Sub

Edit : I managed to bring Macro 2 down to between 0.05s and 0.08s just by cleaning it a bit :

Revised Macro 2 :

Sub addweeknb()
'
' Weekline is the line N° of the second line in the picture, colweek1 is the first column of that line, rngweek is the whole line
' This macro add a line with week number on top of the time line

For i = firstweek To lastweek

numcol1 = WorksheetFunction.Match(i, rngweek, 1) 'find the column nb 
nbcol = WorksheetFunction.CountIf(rngweek, i)
Set rngweek_i = Range(Cells(weekline, colweek1 + numcol1 - nbcol), Cells(weekline, colweek1 + numcol1 - 1))
   With rngweek_i
     .MergeCells = True
     .Font.Name = "Calibri"
     .Font.Size = 12
     .Font.Bold = True
     .Font.ThemeColor = xlThemeColorLight1
     .Value = i
End With

Next i

End Sub

Macro 3 takes about 0.45s in a 1s overall macro

Sub dimgant()
'
' This macro resize the gantt chart
'

' copi the conditional formula in the gantt area as it is now
Range(Cells(firstlinegantt, firstcolgantt), Cells(lastlinegantt, lastcolgantt)) = _
        "=MyFormula"


' Add lines to a liste with matricial formula in excel. It must match the number of line of the gantt
rngfirstlinematformula.AutoFill Destination:=rngmatformule, Type:=xlFillDefault

' Add column if graph goes less than 10 days after the latest date of the project
If lastcolgantt - firstcolgantt < nbofcolumnneeded + 10 Then
rnglastcol.AutoFill Destination:=Range(rnglastcol, Range(Cells(firstlinegantt, lastcolgantt), Cells(lastlinegantt, nbofcolumnneeded + 10))), Type:=xlFillDefault
End If

' Delete column if graph goes further than 10 days after the latest date of the project
If lastcolgantt - firstcolgantt > nbofcolumnneeded + 10 Then
Range(Cells(1, nbofcolumnneeded + 10), Cells(lastlinegantt, lastcolgantt)).Delete Shift:=xlToLeft
End If


End Sub

Thank you all very much.

Источник