Диаграмма Ганта в Excel, обзор и оптимизация кода VBA - PullRequest
Новая
       17

Диаграмма Ганта в Excel, обзор и оптимизация кода VBA

0 голосов
/ 05 апреля 2020

Я сделал диаграмму Ганта Excel с помощью VBA. Это мой первый проект VBA, и я приложил все усилия, чтобы он был чистым и организованным, однако я думаю, что можно было бы провести много оптимизаций.

Я хотел бы спросить вас, ребята, не могли бы вы взглянуть на некоторые части моего кода, который я определил как самый медленный, и скажите, есть ли лучший способ: (Screenupdate, калькуляция автоматического c, события, анимация отключены, и все мои переменные объявлены как publi c и вычислены в другом модуль)

Общий макрос выполняется в 1 с. Я знаю, что это не так долго, но он вызывается каждый раз, когда на листе вносятся изменения вручную. Поэтому я хотел бы уменьшить его как можно больше.

Макрос 1 занимает около 0,2 с в общем макросе 1 с * 

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

Макрос 2 занимает около 0,25 с в общем 1 с. макрос Верхняя строка - это строка, добавленная этим макросом 

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

Редактировать: мне удалось снизить Macro 2 до 0,05–0,08 с, просто немного его очистив:

Пересмотренный Макрос 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

Макрос 3 занимает около 0,45 с в общем макросе 1 с 

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

Спасибо всем большое.

...