VBA範囲内の値に基づいて行全体を新しいシートにコピー

Question

同様の問題に対する回答を検索する複数のスレッドを読み込んでいますが、独自のコードをデバッグできませんでした。

"Aeronautics Engineers"という用語でAEとBFの間のすべてのセルを検索し、その用語を含むすべての行を新しいシートにコピーするマクロを作成しようとしています。どのような援助のための

が

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 

ありがとう：シート全体が、私は運なしに次のコードを使用してみましたが99289.

の合計を持っています！

Answer 1

あなたの問題は、あなたのjループである：配列の

For J = 0 To UBound(strArray) 

は、UpperBound（Ubound）strArrayそれは、単一の要素を持つ配列"Aeronautic"です0です。

ループは1回ループして終了します。

代わりにあなたの範囲をループしてみてください：

ここ

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 

また、あなたが二Forループの代わりにrangeオブジェクトの.find方法を使用することができます。 （必要に応じて両方を使用する必要はありません）。

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