| 
    
     |  | こんにちは 
 >あの、大変失礼ですが
 >>If .Columns(1).Rows.Count = 1 Then
 >これで抽出数は数えられないと思います。
 
 ご指摘のとおりですスミマセン (^^;;
 少し修正しました
 
 
 Sub 抽出2()
 
 Dim sh1 As Worksheet
 Dim sh2 As Worksheet
 Dim MyR As Range
 
 
 Set sh1 = Worksheets("Sheet1")
 Set sh2 = Worksheets("Sheet2")
 
 Set MyR = sh2.Range("a2")
 
 If MyR.Value = "" Then
 MsgBox "A2値を入れてください"
 Exit Sub
 End If
 
 sh2.Range("a6:e65536").ClearContents
 
 
 With sh1.Range("a1").CurrentRegion
 .AutoFilter 1, "*" & MyR.Value & "*"
 If .Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then
 MsgBox "該当データはありません"
 Else
 .Offset(1).Copy sh2.Range("a6")
 End If
 .AutoFilter
 End With
 
 Set sh1 = Nothing
 Set sh2 = Nothing
 Set MyR = Nothing
 
 End Sub
 
 |  |