VBAコードはdebug.modeでのみ正常に動作しています

Question

私のVBAコードは、特定の入力条件に基づいてブック内の複数のシートから別のシートに行をコピー/貼り付けしています。これは、InStr検索を使用して、17〜50行目の列Dの "E"で始まるシート上の入力条件を検索します。これは正常に機能しています。

ただし、ボタンでサブをアクティブにすると、最初に見つかったエントリだけがコピー/ペーストされ、次のワークシートにジャンプします。 debug.modeでは、1つのワークシート内のすべてのエントリを検索し、コピー/ペーストしてから次のワークシートにジャンプします。

変更する必要があるのは何ですか？

Sub request_task_list() 

Dim rPlacementCell As Range 
Dim myValue As Variant 
Dim i As Integer, icount As Integer 

myValue = InputBox("Please enter the Name (Name or Surname) of the Person whos task you are looking for", "Input", "Hansen") 
    If myValue = "" Then 
     Exit Sub 
    Else 
     Set rPlacementCell = Worksheets("Collect_tool").Range("A3") 
     For Each Worksheet In ActiveWorkbook.Worksheets 

     'Only process if the sheet name starts with 'E' 
     If Left(Worksheet.Name, 1) = "E" Then 
      Worksheet.Select 
       For i = 17 To 50 

        If InStr(1, LCase(Range("D" & i)), LCase(myValue)) <> 0 Then 
         'In string search for input value from msg. box 
         'Copy the whole row if found to placement cell 
         icount = icount + 1 
         Rows(i).EntireRow.Copy 
         rPlacementCell.PasteSpecial xlPasteValuesAndNumberFormats 
         Range("D2").Copy 
         rPlacementCell.PasteSpecial xlPasteValues 
         Set rPlacementCell = rPlacementCell.Offset(1) 
        End If 
       Next i   
     End If 
    Next Worksheet 
Worksheets("collect_tool").Activate 
Range("B3").Activate 

End If 

End Sub 

Answer 1

このコードは、私の作品：私はあなたのコードを推測している

Sub request_task_list() 

    Dim rPlacementCell As Range 
    Dim myValue As Variant 
    Dim i As Integer 
    Dim wrkBk As Workbook 
    Dim wrkSht As Worksheet 

    Set wrkBk = ActiveWorkbook 
    'or 
    'Set wrkBk = ThisWorkbook 
    'or 
    'Set wrkBk = Workbooks.Open("C:/abc/def/hij.xlsx") 


    myValue = InputBox("Please enter the Name (Name or Surname) of the Person whos task you are looking for", "Input", "Hansen") 
    If myValue <> "" Then 
     Set rPlacementCell = wrkBk.Worksheets("Collect_tool").Range("A3") 'Be specific about which workbook the sheet is in. 
     For Each wrkSht In wrkBk.Worksheets 
      'Only process if the sheet name starts with 'E' 
      If Left(wrkSht.Name, 1) = "E" Then 
       For i = 17 To 50 
        'Cells(i,4) is the same as Range("D" & i) - easier to work with numbers than letters in code. 
        If InStr(1, LCase(wrkSht.Cells(i, 4)), LCase(myValue)) > 0 Then 'Be specific about which sheet the range is on. 
         'In string search for input value from msg. box 
         'Copy the whole row if found to placement cell 
         wrkSht.Rows(i).EntireRow.Copy 
         rPlacementCell.PasteSpecial xlPasteValuesAndNumberFormats 
         rPlacementCell.Value = wrkSht.Cells(2, 4).Value 
         Set rPlacementCell = rPlacementCell.Offset(1) 
        End If 
       Next i 
      End If 
     Next wrkSht 
     Worksheets("collect_tool").Activate 
     Range("B3").Activate 
    End If 

End Sub 

は、この時点で失敗しました：For Each Worksheet In ActiveWorkbook.Worksheets。 WorksheetはWorksheetsコレクションのメンバーであり、この方法で使用できるとは思いません。私のコードでは、wrkShtをWorksheetオブジェクトとして設定し、wrkShtを使用してループの現在のワークシートを参照しています。