Excel VBA複数のワークシートを検索し、選択した行を集計ワークシートに貼り付けます

Question

現在、複数のワークシートで列D & Kをスキャンしようとしています（数値は異なる場合があります）。列Dの値が9または10の場合、または列Kの値が100より大きい場合は、行全体をサマリー・シートにコピーします。サマリー・ワークシートを作成しますが、それ以上の行はコピーしません。これまで私が持っているものは次のとおりです。

Option Explicit 

Sub AppendDataAfterLastColumn() 
Dim sh As Worksheet 
Dim DestSh As Worksheet 
Dim Last As Long 
Dim CopyRng As Range 
Dim SearchRng As Range 
Dim SearchRng1 As Range 
Dim rngCell As Range 
Dim lastrow As String 

With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Delete the summary worksheet if it exists. 
Application.DisplayAlerts = False 
On Error Resume Next 
ActiveWorkbook.Worksheets("Action Items").Delete 
On Error GoTo 0 
Application.DisplayAlerts = True 

' Add a worksheet with the name "Action Items" 
Set DestSh = ActiveWorkbook.Worksheets.Add 
DestSh.Name = "Action Items" 
Sheets("Action Items").Move Before:=Sheets(3) 

Sheets(4).Select 
Range("A1:U3").Select 
Selection.Copy 
Sheets("Action Items").Select 
Range("A1").Select 
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ 
    SkipBlanks:=False, Transpose:=False 
ActiveSheet.Paste 
Range("a1") = "PFMEA Action Items" 

' Loop through all worksheets and copy the data to the 
' summary worksheet. 
For Each sh In ActiveWorkbook.Worksheets 

     If sh.Name <> DestSh.Name Then 

      Set SearchRng = ActiveSheet.Range("D:D, K:K") 

      ' Find the last row with data on the summary 
      ' worksheet. 
      Last = Worksheets("Action Items").UsedRange.Rows.Count 

       For Each rngCell In SearchRng.Cells 

        If rngCell.Value <> "" Then 

         If rngCell.Value = "9" Or "10" Then 
         'select the entire row 
          rngCell.EntireRow.Select 
          MsgBox Selection.Address(False, False) 
          Selection.Copy 

          ' This statement copies values, formats, and the column width. 

          lastrow = DestSh.Cells(Rows.Count, "A").End(xlUp).Row + 1 
          DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ 
           SkipBlanks:=False, Transpose:=False 

         ElseIf rngCell.Value > 100 Then 

          'select the entire row 
          rngCell.EntireRow.Select 
          Selection.Copy 

          ' This statement copies values, formats, and the column width. 
          lastrow = DestSh.Cells(Rows.Count, "A").End(xlUp).Row + 1 
          DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ 
           SkipBlanks:=False, Transpose:=False 

         End If 

        End If 

       Next rngCell 

     End If 
Next 

ExitTheSub: 

Application.Goto DestSh.Cells(1) 

With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
End With 
End Sub 

ありがとうございました！

Answer 1

また、私はここでの問題は、あなたが、列の幅を貼り付け、それを言っている、あなたのペースト特殊なコードであると思い「PartyHatPanda」

Answer 2

によって与えられたコメントを検討し

If sh.Name <> DestSh.Name Then後 sh.Activateを追加します。コード DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=Falseをコピーしてから、 DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=Falseに変更しました。私にとっては、行と値をコピーします。あなたが書いたやり方では、両方の列dと列kの値が基準に合っているかどうかによって重複が発生する可能性があります。これが望ましくない場合は、行を切り取るか、より多くの基準を設定して作業することができます。これが何かを助けるかどうか見てください！ :)