特定のマクロをより速く実行する方法

Question

誰でもこのマクロの部分を手伝うことができますか？

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 

私は行ごとに行くのループを修正理解し、それが終了することに時間がかかるですので、私は、5000行、より多くを持っている場合..テキスト「ELEVATIONで一つのセルを見つける

マクロ\ AZIMUTH "とそれに続くツリーの行を切断して1つの行に結合します。私はそれが前と後の見方を示すことができます。

おかげ

Answer 1

は、上記のあなたの元の質問の下に私のコメントを参照して、このコードをテストしてみてください。あなたが理解していないコードに行ったことがあれば、コメントしてください。

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

これを行う最も速い方法は、メモリで行い、結果を書き戻すことです。これは、すべてを1つのメモリに読み込み、すべてを1つのメモリに書き戻すことで高速化できます。しかし今のところ、これは行ごとに行われます（さらに速くすべきです）。これはソースデータを上書きしますので、まずコピーでこれをテストしてください。

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