VBAで「上位10位」を自動抽出！面倒な集計作業を1秒で終わらせるコード

【業務効率化】VBA

2026.09.15

「毎回手動で並び替えやコピペをするのが面倒…」
「抽出ミス（11位までコピーしてしまった等）を防ぎたい」

そんなふうに感じたことはありませんか？

今回はそのようなお悩みを一瞬で解決するVBAの活用方法をご紹介していきます。

【業務効率化】VBAの記事を見る

【目次】

コピペでOK！上位10位を抽出するVBAコード
使い方はたったの3ステップ

コピペでOK！上位10位を抽出するVBAコード

今回は、「Sheet1」にある表のB列（スコアなど）を基準に、上位10行を「抽出結果」シートにコピーするコードを作成しました。

Sub ExtractTop10()
    Dim wsData As Worksheet
    Dim wsResult As Worksheet
    Dim lastRow As Long
   
    ' 1. シートの設定
    Set wsData = ThisWorkbook.Worksheets("Sheet1") ' 元データがあるシート名
   
    ' 抽出結果シートがなければ作成、あれば中身を消す
    On Error Resume Next
    Set wsResult = ThisWorkbook.Worksheets("抽出結果")
    On Error GoTo 0
   
    If wsResult Is Nothing Then
        Set wsResult = ThisWorkbook.Worksheets.Add(After:=wsData)
        wsResult.Name = "抽出結果"
    Else
        wsResult.Cells.Clear
    End If
   
    ' 2. データの最終行を確認
    lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
   
    ' 3. オートフィルターを使って上位10位を抽出
    With wsData.Range("A1").CurrentRegion
        .AutoFilter Field:=2, Criteria1:="10", Operator:=xlTop10Items
       
        ' 4. 抽出されたデータをコピーして別シートに貼り付け
        .SpecialCells(xlCellTypeVisible).Copy Destination:=wsResult.Range("A1")
       
        ' 5. フィルターを解除
        .AutoFilter
    End With
   
    wsResult.Activate
    MsgBox "上位10位の抽出が完了しました！", vbInformation
End Sub