У меня проблема с производительностью в коде VBA-Excel. У меня есть 42 строки и 55 столбцов (можно увеличить). Моя цель состоит в том, чтобы объединить ячейки (в каждых 2 строках), которые имеют одинаковое значение, используя некоторые шаги (я хочу составить диаграмму Ганта).Эффект слияния ячейки превосходит производительность VBA
Первый шаг объединены на колонке на основе (за каждые 2 ряда):
- сравнить клеток (строка, столбец) и (строки + 1, Col)
- Если у него такое же значение, сравните ячейку (строка, col) и (строка, col + 1)
- , если оно имеет такое же значение, сравните ячейку (строка, col + 1) и (строка + 1, col + 1), проверьте следующий столбец и перейдите к шагу 1
- , если шаг 2 или 3 является ложным, затем слейте ячейки из первой ячейки (строки, столбца) до последней ячейки, которая имеет одинаковое значение (ячейка (ячейка (ячейка) строка + 1, столбец + п - 1)
- , если шаг 1 является ложным, а затем перейти к следующему столбцу
после этого, я должен объединить на основе ряда (по-прежнему для каждых 2 строк).
- если ячейка (строка, столбец) и сотовый (строка, столбец + 1), которые не объединены, если ячейка (строка, столбец) и сотовый (строка, столбец + 1), имеют то же значение, перейти к следующий столбец.
- , если шаг 1 является ложным, а затем объединить клетки из ячейки (строка, столбец) до ячейки (строка, столбец + п - 1)
Я создал код, приведенный ниже, но я перед лицом производительности вопрос.
Время, необходимое для завершения этого кода, составляет не менее 4 минуты.
Я попытался удалить линию слияния для проверки, и время только 1 секунда.
Я пришел к выводу, что в процессе слияния есть что-то неправильное, но я не мог понять это.
Если у вас есть предложения относительно моего кода, пожалуйста, поделитесь им.
Большое спасибо ...
Sub MergeCell()
Dim StartTime As Double, RunTime As Double
StartTime = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Dim i As Long, j As Long, jmax1 As Long, maxRows As Long, maxCols As Long
Dim merge As Long, iMerge As Long, jMerge As Long, Jump As Long
Dim chckst As String
maxRows = 42
maxCols = 55
Dim Rng As Range, Rng3 As Range
Set Rng = Sheets("Sheet1").Range("E5").Resize(maxRows, maxCols)
Dim chk As Long
i = 1
Do While i < maxRows
j = 1
Do While j < maxCols
iMerge = 0
jMerge = 0
merge = 0
Jump = 0
If Rng.Cells(i, j).Value2 = Rng.Cells(i + 1, j).Value2 Then
jmax1 = j
iMerge = i + 1
jMerge = jmax1
merge = 1
For chk = jmax1 + 1 To maxCols - 1
If Rng.Cells(i, j).Value2 = Rng.Cells(i, chk).Value2 Then
If Rng.Cells(i, chk).Value2 = Rng.Cells(i + 1, chk).Value2 Then
jmax1 = jmax1 + 1
Else
Jump = 1
Exit For
End If
Else
Exit For
End If
Next
Else
j = j + 1
End If
If merge > 0 Then
'when I removed this merge line, the speed is good, like I said before
Range(Rng.Cells(i, j), Rng.Cells(iMerge, jmax1)).merge
j = jmax1 + 1
If Jump = 1 Then
j = j + 1
End If
End If
Loop
i = i + 2
Loop
RunTime = Round(Timer - StartTime, 2)
MsgBox "Run Time = " & RunTime & " seconds", vbInformation
Dim colId1 As Long, colId2 As Long
Dim colct As Long
i = 1
Do While i <= maxRows
j = 1
Do While j < maxCols
merge = 0
jmax1 = j
If Rng.Cells(i, jmax1).MergeCells = True Then
colct = Rng.Cells(i, jmax1).MergeArea.Columns.Count - 1
jmax1 = jmax1 + colct
j = jmax1 + 1
Else
For chk = jmax1 + 1 To maxCols
If Rng.Cells(i, j) = Rng.Cells(i, chk) And Rng.Cells(i, chk).MergeCells = False Then
merge = 1
colId1 = j
colId2 = jmax1 + 1
If chk <> maxCols Then
jmax1 = jmax1 + 1
Else
j = jmax1 + 1
Exit For
End If
Else
j = jmax1 + 1
Exit For
End If
Next
End If
If merge > 0 Then
'when I removed this merge line, the speed is good, like I said before
Range(Rng.Cells(i, colId1), Rng.Cells(i, colId2)).merge
End If
Loop
i = i + 1
Loop
Rng.HorizontalAlignment = xlCenter
Rng.VerticalAlignment = xlCenter
On Error GoTo HERE
HERE:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
RunTime = Round(Timer - StartTime, 2)
MsgBox "Done!" & vbNewLine & "Run Time = " & RunTime & " seconds", vbInformation
End Sub
Я советую вам прекратить использование Гото в вашем коде. Это невозможно. Можете ли вы опубликовать скриншот своего листа до и после запуска этого кода? – jkpieterse
@jkpieterse Я поставил снимок экрана моего листа до и после. Я модифицировал Goto в цикл For. –