VBAループ - 1つの結果のみ

Question

このチュートリアルを使用して、VBAループを作成して列内の値を検索し、すべての行を基準値でプルします。

https://www.youtube.com/watch?v=QOxhRSCfHaw

それは実行されているが、それは実行するのに約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