VBA循环 – 只有1个结果

我正在使用本教程编写VBA循环来search列中的值，并使用条件值抽取所有行。

它正在运行，但运行需要大约5分钟，最终我只有1个结果（行），当我应该得到成千上万。

Sub finddata() '1.Declare Variables '2.Find Records that match criteria and paste them into new worksheet Dim customcode As String Dim finalrow As Long Dim i As Long customcode = Sheets("Sheet2").Range("A1").Value finalrow = Sheets("Raw Data").Range("A252800").End(xlUp).Row For i = 1 To finalrow If Cells(i, 46) = customcode Then Range(Cells(i, 1), Cells(i, 102)).Copy Worksheets("Sheet1").Range("A1").PasteSpecial End If Next i End Sub 

任何帮助是极大的赞赏。

Answer 1

尝试一个数组。

 Sub finddate() Dim dataRng As Range Dim origData, newData Dim i As Long, j As Long, k As Long Dim customcode As String customcode = Sheets("Sheet2").Range("A1").Value With ThisWorkbook.Worksheets("Raw Data") Set dataRng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 102).End(xlUp)) End With origData = dataRng.Value ReDim newData(1 To UBound(origData, 1), 1 To UBound(origData, 2)) j = 1 For i = 1 To UBound(origData, 1) If origData(i, 46) = customcode Then For k = 1 To UBound(origData, 2) newData(j, k) = origData(i, k) Next j = j + 1 End If Next With ThisWorkbook.Worksheets("Sheet1") .Range(.Cells(1, 1), .Cells(j, 102)) = newData End With End Sub