【MOS】【Microsoft Office Excel】【マクロ/VBA】シート内のリストのデータでフィルタリングして項目ごとの別シートを作成してフィルタリングしたリストをコピペするVBA例
- 2015/06/24 16:17
- CreateObject関数
- AutoFilterメソッド
- Copyメソッド
- Pasteメソッド
- Addメソッド
- オートフィルタ
- 58
1番目のシートに下記のようなリストが保存されているとします。
上記のリストをA列でフィルタリングすると、下記のようになります。
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