Question

大家好我正在使用下面的脚本来检查A列的列数，但是它非常慢，我想知道是否有人知道更快的方法。

在这里，我对不同纸张上的一系列单元格进行了比较，一旦进行比较，就会在相邻的列中创建一个复选标记并将其复制并粘贴到最终的纸张中（可能是另一个减速过程）我无法想象没有复制和粘贴的移植方式？

Sub CompareAndMove()
    Dim rng1 As Range, rng2 As Range, i As Long, k As Long, kL As Long, iL As Long, var As Variant, y As Workbook, lRows As Long

    lRows = Sheets("COMPARE").Cells(Rows.Count, 1).End(xlUp).Row
    iL = Sheets("COMPARE").Range("A" & Rows.Count).End(xlUp).Row

    For j = 3 To 4
        For i = 2 To iL
            Set rng1 = Sheets("COMPARE").Range("A" & i)
            Set rng2 = Sheets("COMPARE").Columns(j)

            var = Application.Match(rng1.Value, rng2, 1)

            If Not IsError(Application.Match(rng1.Value, rng2, 0)) Then bln = True
                If bln = True Then
                    rng1.Interior.Color = RGB(255, 255, 0)
                    rng1.Copy
                    rng1.Offset(0, 1).Font.Name = "Wingdings"
                    rng1.Offset(0, 1).Value = ChrW(&HFC)
                End If
            End If
        Next i

        Sheets("COMPARE").Range(Cells(1, 2), Cells(lRows, "B")).Copy
        Sheets("COMPAREFINAL").Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.PasteSpecial Transpose:=True
    Next j

    kL = Sheets("COMPARE").Range("A" & Rows.Count).End(xlUp).Row
    lRows = Sheets("COMPAREOBD").Cells(Rows.Count, 1).End(xlUp).Row

    For j = 3 To 4
        For k = 2 To kL
            Set rng1 = Sheets("COMPAREOBD").Range("A" & i)
            Set rng2 = Sheets("COMPAREOBD").Columns(j)

            var = Application.Match(rng1.Value, rng2, 1)

            If Not IsError(Application.Match(rng1.Value, rng2, 0)) Then bln = True
                If bln = True Then
                        rng1.Interior.Color = RGB(255, 255, 0)
                        rng1.Copy
                        rng1.Offset(0, 1).Font.Name = "Wingdings"
                        rng1.Offset(0, 1).Value = ChrW(&HFC)
                End If
            End If
        Next k

        Set rng1 = Nothing
        Set rng2 = Nothing

        Sheets("COMPAREOBD").Range(Cells(1, 2), Cells(lRows, "B")).Copy
        Sheets("COMPAREFINALOBD").Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.PasteSpecial Transpose:=True
    Next j
End Sub

Answer 1

主要减速在这里，我看到你是使用MATCH公式一次检查一个单元格，如果你的＆＃34; iL＆＃34;超过两位数它实际上会很慢。您可以选择使用MATCH公式填充整个范围旁边的列并替代它吗？

Application.Match很慢，复制和粘贴也用过？

1 个答案: