Wie man bestimmte Makro schneller laufen lässt

Question

Vielleicht kann mir jemand mit diesem Teil des Makros helfen?

Dim LastRow, DataCount, temp As Double 
     i = 1 
     LastRow = 1 
' skaicius sumeta i viena eilute 
     Do While LastRow <> 0 
      Range("A" & i).Select 
      If ActiveCell.Value = "ELEVATION\AZIMUTH" Then 
       'Cut all three row and paste 
       DataCount = Application.WorksheetFunction.CountA(Range(i & ":" & i)) 
       Range("A" & ActiveCell.row + 1, "I" & ActiveCell.row + 1).Cut ActiveCell.Offset(0, DataCount) 
       Range("A" & ActiveCell.row + 2, "I" & ActiveCell.row + 2).Cut ActiveCell.Offset(0, DataCount * 2) 
       Range("A" & ActiveCell.row + 3, "I" & ActiveCell.row + 3).Cut ActiveCell.Offset(0, DataCount * 3) 

      Else 
       LastRow = Application.WorksheetFunction.CountA(Range("A" & i, "A" & i + 10)) 
      End If 
      i = i + 1 
     Loop 

Wenn ich die Schleife verstehen korrigieren, indem Zeile gehen Reihe, aber ich habe mehr als 5000 Zeilen, so ist es eine lange Zeit dauert Ende zu sein ..

Makro der Suche nach einer Zelle mit dem Text „ELEVATION \ AZIMUTH "und danach Baumreihen abschneiden und zu einer Reihe zusammenfügen. Ich kann zeigen, wie es vorher und nachher aussieht.

Dank

Answer 1

meine Ausführungen unter Ihrer ursprünglichen Frage Siehe oben und versuchen, diesen Code getestet. Wenn es etwas gibt, was ich in dem Code getan habe, den Sie nicht verstehen, kommentieren Sie bitte und ich werde es klären.

Option Explicit 

Sub ConsolidateData() 

    With Sheet1 'code name for worksheet 1, change as needed 

     Dim lastRow As Long 
     lastRow = .Range("A" & .Rows.Count).End(xlUp).Row 

     Dim rowCounter As Long 
     For rowCounter = lastRow To 1 Step -1 

      If .Cells(rowCounter, 1) = "ELEVATION\AZIMUTH" Then 

       Dim i As Integer 
       For i = 1 To 3 

        Dim CopyRange As Range 
        Set CopyRange = .Range(.Cells(rowCounter + i, 1), .Cells(rowCounter + i, 1).End(xlToRight)) 

        Dim cols As Integer 
        cols = CopyRange.Columns.Count 

        .Cells(rowCounter, 1).End(xlToRight).Offset(, 1).Resize(1, cols).Value = CopyRange.Value 

       Next 

       Dim rngRemove As Range 
       If rngRemove Is Nothing Then 
        Set rngRemove = .Cells(rowCounter + 1, 1).Resize(3, 1) 
       Else 
        Set rngRemove = Union(rngRemove, .Cells(rowCounter + 1, 1).Resize(3, 1)) 
       End If 

      End If 

     Next 

     rngRemove.EntireRow.Delete 

    End With 

End Sub 

Answer 2

Der schnellste Weg ist, es im Speicher zu tun und die Ergebnisse zurückzuschreiben. Dies könnte beschleunigt werden, indem alles auf einmal in den Speicher eingelesen wird/alles auf einmal geschrieben wird. Aber jetzt tut dies Zeile für Zeile (sollte noch schneller sein). Dies überschreibt Ihre Quelldaten, daher sollten Sie diese zuerst auf einer Kopie testen.

Public Sub Example() 
    Dim i As Long, j As Long, r As Long 
    Dim Results As Variant, tmp As Variant 

    With ActiveSheet 
     For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1 
      If UCase(.Cells(i, 1).Value2) = "ELEVATION\AZIMUTH" Then 
       With Range(.Cells(i, 1), .Cells(i, 1).Offset(3, 8)) 
        tmp = .Value2 
        .ClearContents 
       End With 
       ReDim Results(LBound(tmp, 1) To UBound(tmp, 1) * UBound(tmp, 2)) 
       For r = LBound(tmp, 1) To UBound(tmp, 1) 
        j = LBound(tmp, 2) 
        Do 
         Results(j + IIf(r > 1, UBound(tmp, 2) * (r - 1), 0)) = tmp(r, j) 
         j = j + 1 
        Loop While j <= UBound(tmp, 2) 
       Next r 

       Range(.Cells(i, 1), .Cells(i, UBound(Results))) = Results 
      End If 
     Next i 
    End With 
End Sub