search
LoginSignup
3

posted at

updated at

Organization

<Excel VBA>表からデータを抽出して別シートに表作成

概要

この記事では、Excelの表から指定したキーの行を抽出し、別シートに表を作成するというマクロ処理のVBAソースコードを公開します。

必要となるシート

ここでは、ソースコードの前に、マクロを実行する上で必要となるExcelシートを簡単に説明します。

まず、抽出元となる表です。
画像では下が切れていますが、47都道府県の都道府県庁所在地、市・町・村それぞれの数を表にしています。

①「都道府県一覧」シート

①「都道府県一覧」シート.JPG
続いて、キーとなる「コード」だけを記載したシートです。
特定の行だけを抽出できるよう、フィルター機能を使っています。

②「キー(コード)」シート

②「キー(コード)」シート.JPG
抽出した行から表を作成するシートです。
「実行」ボタンをクリックすることで、マクロを実行し、表を作成します。

③「抽出結果」シート

1-10-1-02.JPG

ソースコード

①の表から②で指定した行のみを抽出し、③に表を作成するという処理内容です(シートを番号で表記)。

Sub Prefectures()

Dim ws_pref As Worksheet: Set ws_pref = Worksheets("都道府県一覧")
Dim ws_key As Worksheet: Set ws_key = Worksheets("キー(コード)")
Dim ws_result As Worksheet: Set ws_result = Worksheets("抽出結果")

With ws_key
    .Range("a1").CurrentRegion.SpecialCells(xlVisible).Copy ws_result.Range("a1")
    If .FilterMode = True Then
        .ShowAllData
    End If
End With

Dim arr As Variant
With ws_result
    arr = .Range(.Range("a2"), .Cells(Rows.Count, 1).End(xlUp))
End With

Dim brr As Variant
brr = WorksheetFunction.Transpose(arr)
Dim strArray() As Variant
Dim i As Integer

For i = 1 To UBound(brr)
ReDim Preserve strArray(i - 1)
strArray(i - 1) = str(brr(i))
Next

With ws_pref
    .Range("a1").AutoFilter field:=1, Criteria1:=strArray, Operator:=xlFilterValues
    .Range("a1").CurrentRegion.SpecialCells(xlVisible).Copy ws_result.Range("a1")
    .AutoFilterMode = False
End With


MsgBox "処理が完了しました"

End Sub

詳しい説明は、以下、ご参照ください。

参考

WorksheetFunctionについて
WorksheetFunction(ワークシート関数の使い方)
AutoFilter

マクロVBAの準備や実行方法などの使い方は、以下のサイトで確認できます。
Excelマクロの使い方入門(初心者向け)!作成〜保存方法まで
エクセルの神髄 ExcelマクロVBA入門編
因みに、私は「エクセルの神髄」で勉強しました。実際に手を動かしてみるのが1番だと思います。
マクロVBAにかかわらず、ショートカットキーを覚えると便利ですよ!

実行結果

②でキーとなる「コード」を選択(フィルタリング)します。
※図では、2、13、18、21、26を選択
③実行結果.JPG
「実行」ボタンをクリックすると、②で選択した行を抽出した表が③に作成され、ダイアログボックスが表示されます。
④実行結果.png

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
What you can do with signing up
3