Question

是否有任何方法可以让这段代码一行一行地运行得更快？

Sub cut_good_row_range_from_sh2_to_sh1()
  Application.ScreenUpdating = False
  For i = 2 To Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    For j = 2 To Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row

      'Caution: I want to cut BB:BD, so I select BA:BD !
      If Sheets("sheet1").Range("A" & i).Value = Sheets("sheet2").Range("A" & j).Value Then
        Sheets("sheet2").Range("BA" & j & ":BS" & j).Cut Sheets("sheet1").Range("BA" & i & ":BS" & i)
      End If
    Next j
  Next i
  Application.ScreenUpdating = True
End Sub

谢谢;）

Answer 1

已经多次证明循环遍历范围很慢，并且在变体数组上循环要快得多。

“最佳”方法取决于用例的具体情况。尽可能少做假设，这个演示展示了它的有效性。做出的假设是

仅需要数据，不传输格式。
目的地范围内没有公式（如果存在，则会被当前值覆盖）

这是一个简单的例子，可以进行进一步的优化。

Sub Demo()
    Dim Found As Boolean
    Dim i As Long, j As Long, k As Long
    Dim rSrcA As Range, rSrc As Range
    Dim vSrcA As Variant, vSrc As Variant
    Dim rDstA As Range, rDst As Range
    Dim vDstA As Variant, vDst As Variant
    Dim rClear As Range

    ' Get references to Source Data Range and Variant Array
    With Worksheets("Sheet2")
        Set rSrcA = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
        vSrcA = rSrcA.Value
        Set rSrc = .Range("BA1:BS1").Resize(UBound(vSrcA, 1))
        vSrc = rSrc
    End With

    ' Get references to Destination Data Range and Variant Array
    With Worksheets("Sheet1")
        Set rDstA = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
        vDstA = rDstA.Value
        Set rDst = .Range("BA1:BS1").Resize(UBound(vDstA, 1))
        vDst = rDst
    End With

    ' Loop Source
    For i = 1 To UBound(vSrcA, 1)
        ' Loop Destination
        For j = 1 To UBound(vDstA, 1)
            ' Compare
            If vSrcA(i, 1) = vDstA(j, 1) Then
                Found = True
                ' Update Destination Data Array, to be copied back to sheet later
                For k = 1 To UBound(vSrc, 2)
                    vDst(j, k) = vSrc(i, k)
                Next
            End If

        Next
        ' If match found, track Source range to clear later
        If Found Then
            If rClear Is Nothing Then
                Set rClear = rSrc.Rows(i)
            Else
                Set rClear = Union(rClear, rSrc.Rows(i))
            End If
            Found = False
        End If
    Next

    ' Update Destination Range
    rDst.Value = vDst
    ' Clear Source Range
    rClear.ClearContents

End Sub

在15个源行和200个目标行的测试数据集上运行时，执行时间从大约17秒减少到大约10毫秒

从sh2到sh1切割'良好行范围'的代码更快？

1 个答案: