値を検索するマクロが必要な場合は、値と行が上の行を選択します。

Question

私はあなたを混乱させないように願っていますが、ここで私がしようとしていることがあります。基本的に私は、例えば6 4桁の数字の基準を持っている

Excel Screenshot

：ここ

は、シート内のデータの一部がどのように見えるかの例です（3413,3414,3417など）、これらの数字のいずれかで始まる番号を持つ行を検索し、値が入っている行と上の行の両方を新しいシートにコピーするマクロが必要です。私はそれに顧客の名前があるので、上記の行が必要です。マクロは、行2の値を検索し、両方の行2をコピーして、1

を行う。この場合

私は誰が助けることができ、私と同じ問題を持っている人を見つけることができないよう？ありがとう！

編集 - これはおそらく私の開始コードのようになります。このような

Sub Test() 
For Each Cell In Sheets(1).Range("J:J") 
    If Cell.Value = "131125" Then 
     matchRow = Cell.Row 
     Rows(matchRow & ":" & matchRow).Select 
     Selection.Copy 

     Sheets("Sheet2").Select 
     ActiveSheet.Rows(matchRow).Select 
     ActiveSheet.Paste 
     Sheets("Sheet1").Select 
    End If 
Next 
End Sub 

Answer 1

何か：

Sub Test() 
    Dim c As Range, shtSrc As Worksheet, shtDest As Worksheet 
    Dim arr, v, txt, destRow As Long 

    arr = Array(3413, 3414, 3417) '<< array of values to look for 

    Set shtSrc = Sheets("Sheet1") 
    Set shtDest = Sheets("Sheet2") 
    destRow = 2 'start copying to here 

    'ignore empty ranges 
    For Each c In Application.Intersect(shtSrc.Range("J:J"), _ 
             shtSrc.UsedRange).Cells 
     txt = c.Value 
     For Each v In arr 
      'does the cell contain the search number ? 
      If txt Like "*" & v & "*" Then 
       'copy to same row on sheet2 
       c.EntireRow.Resize(2).Copy shtDest.Cells(c.Row, 1) 

       '...or copy below previous hit 
       'c.EntireRow.Resize(2).Copy shtDest.Cells(destRow, 1) 
       'destRow = destRow + 2 

       Exit For '<< stop checking this row 
      End If 
     Next v 
    Next 

End Sub