Question

嗨我在A：J列中有大量数据。如果A列中有一个数字1，我需要一个宏来复制列B：J并将其粘贴到Sheet2中最后一个条目下的Sheet2中。

我已经编写了几个宏来执行此操作，但它们都需要很长时间才能运行，并且由于循环遍历每一行数据以检查它是否为A列中的标识符而效率非常低。

如果没有整个代码循环遍历所有9,000行数据，是否有一种有效的方法呢？

1可能只出现在前2,500（最大）行中，但这个数量每月都会变化。

1将永远是彼此相邻的 - 也就是说，一旦它向下搜索A列以找到1 - 所有其他事件将是1，直到它变为2。也没有差距。 TIA

Answer 1

这是非常即时的，我设置了16,000行的示例，速度非常快。我假设row1有标题。

Sub GetIt()

    Dim sh As Worksheet, ws As Worksheet
    Dim LstRw As Long, rng As Range

    Set sh = ActiveSheet
    Set ws = Sheets("Sheet2")
    Application.ScreenUpdating = 0

    With sh
        LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rng = .Range("B2:J" & LstRw)
        .Columns("A:A").AutoFilter Field:=1, Criteria1:="1"
        rng.SpecialCells(xlCellTypeVisible).Copy
        ws.Cells(ws.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial xlValues
        .AutoFilterMode = 0
        Application.CutCopyMode = 0
    End With

End Sub

Answer 2

作为替代方案，我已将sheet1中的所有数据加载到二维数组中，然后检查数组的第一个元素(x, 1)，如果此元素的值为1则元素(x, 2)到(x, 10)被复制到第二个收集所有结果的数组。检查完所有行后，第二个数组将一次性添加到第二个工作表的表中。结果是：

在1,08秒内检查了100.000行，已将49.960行复制到Sheet2。

出于好奇，我检查了Excel允许结果的最大行数：

在8,05秒内检查了1.048.574行，已将524.340行复制到Sheet2。

假设

2个工作表
目标格式为表格（listobject）

我可以补充说，有些解决方案更简单。

Option Explicit

Sub copyData()
    Dim wsDat As Worksheet, wsDes As Worksheet
    Dim tblDes As ListObject
    Dim i As Long, j As Long, k As Long
    Dim arrDat() As Variant, arrDes() As Variant
    Dim lastRow As Long, lastColumn As Long, nextRow As Long
    Dim rngDes As Range

    Set wsDat = ThisWorkbook.Worksheets(1)  'Change the numbers 1 and 2 to the names of the actual sheets and tables
    Set wsDes = ThisWorkbook.Worksheets(2)
    Set tblDes = wsDes.ListObjects(1)

    With wsDat
        lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lastRow = .Cells(.Rows.Count, lastColumn).End(xlUp).Row
        arrDat = .Range(.Cells(1, 1), .Cells(lastRow, lastColumn))
    End With

    For i = 1 To UBound(arrDat, 1)
        If arrDat(i, 1) = 1 Then
            j = j + 1
        End If
    Next i
    ReDim arrDes(1 To j, 1 To lastColumn - 1)

    k = 1
    For i = 1 To UBound(arrDat, 1)
        If arrDat(i, 1) = 1 Then
            For j = 1 To UBound(arrDes, 2)
                arrDes(k, j) = arrDat(i, j + 1)
            Next j
            k = k + 1
        End If
    Next i

    With wsDes
        tblDes.ListRows.Add
        nextRow = tblDes.ListRows.Count
        Set rngDes = tblDes.DataBodyRange(nextRow, 2)
        Set rngDes = rngDes.Resize(UBound(arrDes, 1), UBound(arrDes, 2))
        rngDes.Value = arrDes
    End With

End Sub

根据大量数据集中A列中的标识符复制单元格

2 个答案: