| 
    
     |  | こんにちは 
 【23982】のマクロに記録したコードをちょっと修正したものです。
 検索結果とは合計値でいいのですよね?
 
 Sub test()
 Dim s As String
 
 s = "リンゴ"
 
 Application.ScreenUpdating = False
 With Worksheets("Sheet2")
 .Range("A1").ClearOutline
 .Range("A:F").ClearContents
 Worksheets("Sheet1").Range("A1").CurrentRegion.Copy
 .Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
 False, Transpose:=False
 .Range("A1").Sort _
 Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes
 .Range("A1").Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4, 5, 6), _
 Replace:=True, PageBreaks:=False, SummaryBelowData:=True
 .Range("A1").ClearOutline
 .Range("A1").CurrentRegion.Value = .Range("A1").CurrentRegion.Value
 .Range("B:B").Find(s & " 計", , xlFormulas, xlWhole) _
 .Offset(, 4).Copy .Range("H1")
 End With
 Application.ScreenUpdating = True
 End Sub
 
 |  |