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

宏查找一个带有文本的单元格＆＃34; ELEVATION \ AZIMUTH＆＃34;并在它之后切割树行并组合成一行。我可以展示它之前和之后的样子。

由于

Answer 1

最快的方法是在内存中执行此操作并回写结果。这可以通过一次性将所有内容读入内存/一次性写回所有内容来加速。但是现在这是逐行的（仍然应该更快）。这将覆盖您的源数据，因此请务必先在副本上进行测试。

function checkWin(currentPlayer) {
    setTimeout(() => {
       alert('Player '+ currentPlayer +' has won');
       resetGame();
    }, 1000);
}

Answer 2

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

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

如何让特定的宏运行得更快

2 个答案: