VBA基於範圍值將整個行復制到新工作表

Question

儘管閱讀了幾個線程來搜索類似問題的答案，但我一直無法自行調試我的代碼。

我試圖編寫一個宏來搜索AE和BF之間的術語「航空工程師」的所有單元格，然後將包含該術語的所有行復制到新工作表。整個片共有99289.

我曾嘗試使用下面的代碼沒有任何的運氣嘗試：

Sub MoveAero() 
Dim strArray As Variant 
Dim wsSource As Worksheet 
Dim wsDest As Worksheet 
Dim NoRows As Long 
Dim DestNoRows As Long 
Dim I As Long 
Dim J As Integer 
Dim rngCells As Range 
Dim rngFind As Range 
Dim Found As Boolean 

strArray = Array("Aeronautic") 

Set wsSource = ActiveSheet 

NoRows = wsSource.Range("A65536").End(xlUp).Row 
DestNoRows = 1 
Set wsDest = ActiveWorkbook.Worksheets.Add 

For I = 1 To NoRows 

    Set rngCells = wsSource.Range("AE" & I & ":BF" & I) 
    Found = False 
    For J = 0 To UBound(strArray) 
     Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing) 
    Next J 

    If Found Then 
     rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows) 

     DestNoRows = DestNoRows + 1 
    End If 
Next I 
End Sub 

感謝任何幫助！

Answer 1

你的問題是在你的j循環：

For J = 0 To UBound(strArray) 

數組的上界（Ubound）strArray爲0。這是一個單一的元素"Aeronautic"的數組。

所以你的循環正在循環一次並退出。

而是試圖通過您的循環範圍：

For Each rngCell in rngCells.Cells 
    if rngCell.value = "Aeronatic" Then 
     Found = True 
     Exit For 
    End if 
Next rngCell 

在這裏，我們通過您剛纔的電池後，電池是rngCells範圍內循環。然後我們測試該單元格是否具有您正在查找的值。如果我們找到它，我們將found設置爲true並退出for循環。您不必退出for循環，但我們找到了我們想要的，所以沒有理由不保存一些cpu時間。

---

的完整代碼，刪除不必要的變量和移動一點點圍：

Sub MoveAero() 
Dim wsSource As Worksheet 
Dim wsDest As Worksheet 
Dim NoRows As Long 
Dim DestNoRows As Long 
Dim I As Long 
Dim J As Integer 
Dim rngCells As Range 
Dim rngCell as Range 

Set wsSource = ActiveSheet 

NoRows = wsSource.Range("A65536").End(xlUp).Row 
DestNoRows = 1 
Set wsDest = ActiveWorkbook.Worksheets.Add 

For I = 1 To NoRows 

    Set rngCells = wsSource.Range("AE" & I & ":BF" & I) 

    For Each rngCell in rngCells.Cells 
     if rngCell.value = "Aeronatic" Then 
      'Moved this logic up from the IF block below 
      rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows) 
      DestNoRows = DestNoRows + 1 
      Exit For 
     End if 
    Next rngCell 

Next I 
End Sub 

或者，你可以使用range對象是.find方法，而不是第二For循環。 （不需要使用兩者來滿足您的需求）。

Sub MoveAero() 
Dim wsSource As Worksheet 
Dim wsDest As Worksheet 
Dim NoRows As Long 
Dim DestNoRows As Long 
Dim I As Long 
Dim rngCells As Range 

Set wsSource = ActiveSheet 

NoRows = wsSource.Range("A65536").End(xlUp).Row 
DestNoRows = 1 
Set wsDest = ActiveWorkbook.Worksheets.Add 

For I = 1 To NoRows 

    Set rngCells = wsSource.Range("AE" & I & ":BF" & I) 

    'Try to find your search term in the range 
    If Not (rngCells.Find("Aeronautic") Is Nothing) Then 
     rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows) 
     DestNoRows = DestNoRows + 1 
    End If 

Next I 
End Sub