• 虹色ミツバチ
  • freoカスタマイズメモ、テンプレート・プラグイン配布/officeTIPS
検索プラグイン
虹色ミツバチ

> Entry >MOS>Microsoft Office Excel>マクロ/VBA> シート内のリストのデータでフィルタリングして項目ごとの別シートを作成してフィルタリングしたリストをコピペするVBA例

【MOS】【Microsoft Office Excel】【マクロ/VBA】シート内のリストのデータでフィルタリングして項目ごとの別シートを作成してフィルタリングしたリストをコピペするVBA例

1番目のシートに下記のようなリストが保存されているとします。

01.png

上記のリストをA列でフィルタリングすると、下記のようになります。

02.png
03.png
04.png

A列の情報をもとに重複のないワークシートを挿入し、上記3つのリストをそれぞれのシートにコピペする方法は以下のとおりです。

Sub Make_Fruits_Sheet()
'====================================================================================
' A列のデータでフィルタリングして別シートを作成しフィルタリングしたリストをコピペする
'====================================================================================
ThisWorkbook.Activate
'//変数の定義
    Dim arrayData, i, maxRow As Long
    Dim cellData As String
    Set arrayData = CreateObject("Scripting.Dictionary")
    On Error Resume Next
'//A列の最終行を取得
    If Len(Worksheets(1).Range("A1").Value) = 0 Then
        maxRow = 0
    ElseIf Len(Worksheets(1).Range("A2").Value) = 0 Then
        maxRow = 1
    Else
        maxRow = Worksheets(1).Range("A1").End(xlDown).Row
    End If
'//A列のデータを連想配列に格納する
    For i = 2 To maxRow
        '//セルの値を変数cellDataに格納
            cellData = Range("A" & i).Value
        '//連想配列に未登録であればセルの値を連想配列に格納する
            If Not arrayData.Exists(cellData) Then
                arrayData.Add cellData, cellData
            End If
    Next i
'//連想配列のキーを定義する
    arrayDataKeys = arrayData.Keys
'//連想配列のデータ分繰り返して作業する
    For i = 0 To arrayData.Count - 1
        '//新しいワークシートを挿入する
            Dim NewWorkSheet As Worksheet
            Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        '//新しいワークシートの名前を変える
            NewWorkSheet.Name = arrayDataKeys(i)
        '//元のシートをフィルタリングしてコピーする
            With Worksheets(1).Range("A1")
                .AutoFilter Field:=1, Criteria1:=arrayDataKeys(i)    '1列目を連想配列のデータで絞り込む
                .CurrentRegion.Copy
            End With
        '//新しいワークシートにペーストする
            Sheets(arrayDataKeys(i)).Paste
    Next i
'//フィルタを解除する
    With Worksheets(1)
        .Activate                    '最初のシートをアクティブにする
        .Range("A1").AutoFilter      'フィルタを解除する
    End With
'//オブジェクトを初期化して終了
    Set arrayData = Nothing
End Sub

ページ移動

関連記事

ユーティリティ

Twitter

ページ上部へ