Excel 如何使特定宏运行得更快

也许有人能帮我做这部分宏

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多行，所以需要很长时间才能完成

宏查找一个具有文本仰角\方位角的单元格，并在其后剪切树行并合并为一行。我可以展示它前后的样子

---

谢谢

请在上面的原始问题下查看我的评论，并尝试此测试代码。如果我在代码中做了任何您不理解的事情，请评论，我会澄清

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

---

最快的方法是在内存中执行并写回结果。通过一次性将所有内容读入内存/一次性将所有内容写回内存，可以加快速度。但就目前而言，一行一行地进行应该会更快。这将覆盖您的源数据，因此请确保先在副本上进行测试

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

一个快速提示是删除RangeA&i。如果RangeA&i=仰角\方位角，则选择并仅写入，然后每次执行剪切操作和工作表函数调用都会减慢速度。