Merge Zelle Excel VBA Zeit Leistung

Question

Ich habe ein Performance-Problem in meinem VBA-Excel-Code. Ich habe 42 Zeilen und 55 Spalten (es kann erhöht werden). Mein Zweck ist es, die Zellen (in jeweils 2 Zeilen), die den gleichen Wert haben, über einige Schritte zusammenzuführen (ich möchte ein Gantt-Diagramm erstellen).

Before merge

After merge

Der erste Schritt wird auf Spalte basiert verschmolzen (je 2 Reihen):

1. Zelle (Row, Col) und (Zeile + 1, col) zu vergleichen,
2. Wenn es denselben Wert hat, vergleiche Zelle (Zeile, Spalte) und (Zeile, Spalte + 1)
3. Wenn es denselben Wert hat, vergleiche Zelle (Zeile, Spalte + 1) und (Zeile + 1), col + 1), überprüfen Sie die nächste Spalte und gehen Sie zu Schritt 1
4. wenn Schritt 2 oder 3 falsch ist, dann fusionieren Sie die Zellen aus der ersten Zelle (Zeile, Spalte) bis zur letzten Zelle, die den gleichen Wert (Zelle (Zeile + 1, col + n - 1)
5. wenn Schritt 1 falsch ist, dann in der nächsten Spalte

danach gehen, ich habe auf Zeile fusionieren für jeweils 2 Zeilen basierend (noch).

1. , wenn die Zelle (Zeile, Spalte) und Zelle (Zeile, Spalte + 1) nicht verschmolzen, wenn die Zelle (Zeile, Spalte) und Zelle (Zeile, Spalte + 1) den gleichen Wert hat, gehen Sie zu nächste Spalte.
2. Wenn Schritt 1 falsch ist, verschmelzen dann die Zellen von der Zelle (Row, Col) bis Zelle (Row, Col + n - 1)

I den Code erstellt haben, aber ich bin eine Leistung zugewandten Problem.

Die Zeit bis zur Fertigstellung dieses Codes beträgt mindestens 4 Minuten.

Ich habe versucht, die Merge-Linie für die Überprüfung zu entfernen, und die Zeit ist nur 1 Sekunde.

Ich kam zu dem Schluss, dass etwas auf dem Merge-Prozess nicht korrekt ist, aber ich konnte es nicht herausfinden.

Wenn Sie einen Vorschlag bezüglich meines Codes haben, teilen Sie es bitte.

Thank you very much ...

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 

Answer 1

Das Problem besteht in der bedingten Formatierung.

Ich muss nur die bedingte Formatierung vor der Zusammenführung entfernen, fusionieren und die bedingte Formatierung erneut einfügen.

Mit diesem Code ist jetzt alles in Ordnung und schnell. Es braucht nur 2 Sekunden.

Danke für alle, die ..

Bezug zu helfen, trägt,

Answer 2

Suggestion 1

Variablen wie folgt erklären: Dim i as long, j as long, jmax1 as long, maxRows as long, maxCols as long etc. Wenn Sie den Typ nicht angeben, bekommen sie als Variante deklariert. In Ihrer Zeile wird nur die letzte - Jump als lang deklariert. Wenn Sie sie neu deklarieren, kann es schneller ausgeführt werden.

Suggestion 2

Verwenden ganze Zahlen in VBA nicht. Paketüberfluss.com/Fragen/26409117/

Suggestion 3

nicht GoTohttps://en.wikipedia.org/wiki/Spaghetti_code

Suggestion 4

Im Allgemeinen merge ist in VBA/Excel langsam anwenden. Aber immer noch, um zu sehen, was Sie tun, schreiben Sie dies vor der Zusammenführung: debug.Print Range(Rng.Cells(i, j), Rng.Cells(iMerge, jmax1)).Address Es kann sein, dass Sie mehr als erwartet oder etwas anderes verschmelzen.