データを振り分ける:Excel VBA入門

データをある項目で分類したいという質問をよく見かけます。
シートにデータを振り分けるとすると、データが2重になるのでファイル容量は単純に倍と大きくなります。
必要な項目だけを別シートに抽出すれば済みそうにも思いますが、ここではVBAの練習を兼ねてコードを考えてみたいと思います。
以下のコードはちょこちょこっと書いたので無駄な部分があるとは思いますが、ご了承ください。

スポンサードリンク

データをシートに振り分ける

【前提条件】
- 振り分け先のシートは事前に準備されているものとします。
- 振り分け先のシート名と振り分けの条件となる項目名は一致しているものとします。

オートフィルタを利用する方法(A)

単純に元データを振り分け先シートにコピーします。
ここで、オートフィルタのオプションでシート名と「等しくない」データを抽出します。
抽出したデータを削除します。

これで、シート名と同じ項目のデータだけが残るという仕組みです。
ただし、元データをいったんコピーしていますので、一時的ではありますがファイル容量はかなり大きくなります。

【コード例】

シート見出し「果物」を右クリックして、表示されるVBAのコード入力欄へ下記のコードを入力（コピー&貼り付け）します。
シート「野菜」のモジュールにも同じコードを記述します。

Private Sub Worksheet_Activate()
　　Application.ScreenUpdating = False
　　　　'----データ削除
　　　　Range("1:" & Rows.Count).Delete
　　　　'----元データをコピー&貼り付け
　　　　Sheets("Sheet1").Range("A1").CurrentRegion.Copy Range("A1")
　　　　'----オートフィルタで該当しないデータを抽出
　　　　With Range("A1").CurrentRegion
　　　　　　.AutoFilter
　　　　　　.AutoFilter Field:=2, Criteria1:="<>" & ActiveSheet.Name, Operator:=xlAnd
　　　　'----抽出↓データを削除
　　　　　　Rows("2:" & Rows.Count).Delete Shift:=xlUp
　　　　　　.AutoFilter
　　　　End With
　　　　Range("A1").Select
　　　　Application.ScreenUpdating = True
End Sub

VBEの状態

【実行例】
- Sheet1の元データ
- 実行後の各シート
  Sheet「果物」
  
  Sheet「野菜」

オートフィルタを利用する方法(B)

元データをオートフィルタで抽出して、抽出データをシートにコピーする方法も考えられます。
こちらの方が素直な考え方ですね・・・(^^ゞ

【コード例】

シート見出し「果物」を右クリックして、表示されるVBAのコード入力欄へ下記のコードを入力（コピー&貼り付け）します。
シート「野菜」のモジュールにも同じコードを記述します。

Private Sub Worksheet_Activate()
　　Application.ScreenUpdating = False
　　　　'----データ削除
　　Range("1:" & Rows.Count).Delete
　　　　'----オートフィルタでデータを抽出
　　With Sheets("Sheet1").Range("A1").CurrentRegion
　　　　.AutoFilter
　　　　.AutoFilter Field:=2, Criteria1:="=" & ActiveSheet.Name, Operator:=xlAnd
　　　　'----抽出データをコピー&貼り付け
　　　　.Copy ActiveSheet.Range("A1")
　　　　.AutoFilter
　　End With
　　Range("A1").Select
　　Application.ScreenUpdating = True
End Sub

実行後は下記のようにデータが振り分けられます。
- Sheet1の元データ
- 実行後の各シート
  Sheet「果物」
  
  Sheet「野菜」

元データのシートのみがある場合(振り分け先のシートがない時は？)

振り分け先のシートが存在するか否かを調べます。
- シートがある場合はデータをいったん削除し、初期状態(列見出しのみを作成する)にします。
- シートがない場合はシートを追加して、初期状態(列見出しのみを作成する)にします。
データを順次転記します。
効率は悪いのですが、考え方は単純で理解しやすいと思います。

【コード例】

標準モジュールに下記コードを入力（コピー&貼り付け）して、実行します。

Sub test1()
　　Dim i As Long
　　Dim lastRow As Long
　　Dim mySh As Worksheet
　　Dim myFlg As Boolean
　　Dim myRow As Long
　　Dim myKey As String
　　　　lastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
　　　　For i = 2 To lastRow
　　　　　　'----振り分け先のシートが存在するか否かをチェック
　　　　　　For Each mySh In Worksheets
　　　　　　　　myFlg = False
　　　　　　　　myKey = Worksheets("Sheet1").Range("B" & i).Value
　　　　　　　　If mySh.Name = myKey Then
　　　　　　　　　　myFlg = True
　　　　　　　　　　mySh.Cells.Delete
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next mySh
　　　　　　'----振り分け先のシートがなかったらシートを追加する
　　　　　　If myFlg = False Then
　　　　　　　　ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myKey
　　　　　　End If
　　　　　　'----列見出しをコピー&貼り付け
　　　　　　Worksheets("Sheet1").Range("A1:C1").Copy Worksheets(myKey).Range("A1")
　　　　Next i
　　　　'----データを転記する
　　　　For i = 2 To lastRow
　　　　　　　　myKey = Worksheets("Sheet1").Range("B" & i).Value
　　　　　　If myKey <> "" Then
　　　　　　　　myRow = Worksheets(myKey).Range("A" & Rows.Count).End(xlUp).Row + 1
　　　　　　　　Worksheets("Sheet1").Range("A" & i & ":C" & i).Copy _
　　　　　　　　　　Worksheets(myKey).Range("A" & myRow & ":C" & myRow)
　　　　　　End IF
　　　　Next i
End Sub

実行後は下記のようにデータが振り分けられます。
- Sheet1の元データ
- 実行後の各シート
  Sheet「果物」
  
  Sheet「野菜」

Dictionaryで重複しない項目を取り出して処理する

Dictionaryで重複しない項目を取り出します。
振り分け先のシートが存在するか否かを調べます。
- シートがある場合はデータをいったん削除し、初期状態(列見出しのみを作成する)にします。
- シートがない場合はシートを追加して、初期状態(列見出しのみを作成する)にします。
データを順次転記します。
上のコードより、ちょっとだけ効率が上がります。

【コード例】

標準モジュールに下記コードを入力（コピー&貼り付け）して、実行します。

Sub test2()
　　Dim myDic As Object, myKey
　　Dim c, myVal
　　Dim i As Long
　　Dim mySh As Worksheet
　　Dim myFlg As Boolean
　　Dim lastRow As Long, myRow As Long
　　Dim myK As String
　　　　Set myDic = CreateObject("Scripting.Dictionary")
　　　　' ---(1)元データの項目を配列に格納
　　　　lastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
　　　　myVal = Worksheets("Sheet1").Range("B2", "B" & lastRow).Value
　　　　' ---(2)myDicへデータを格納
　　　　For Each c In myVal
　　　　　　If Not c = Empty Then
　　　　　　　　If Not myDic.Exists(c) Then
　　　　　　　　　　myDic.Add c, ""
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　　　'----振り分け先のシートが存在するか否かをチェック
　　　　myKey = myDic.Keys
　　　　For i = 0 To myDic.Count - 1
　　　　　　For Each mySh In Worksheets
　　　　　　　　myFlg = False
　　　　　　　　If mySh.Name = myKey(i) Then
　　　　　　　　　　myFlg = True
　　　　　　　　　　mySh.Cells.Delete
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next mySh
　　　　　　'----振り分け先のシートがなかったらシートを追加する
　　　　　　If myFlg = False Then
　　　　　　　　ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myKey(i)
　　　　　　End If
　　　　　　'----列見出しをコピー&貼り付け
　　　　　　Worksheets("Sheet1").Range("A1:C1").Copy Worksheets(myKey(i)).Range("A1")
　　　　Next i
　　　　'----データを転記する
　　　　For i = 2 To lastRow
　　　　　　myK = Worksheets("Sheet1").Range("B" & i).Value
　　　　　　If myK <> "" Then
　　　　　　　　myRow = Worksheets(myK).Range("A" & Rows.Count).End(xlUp).Row + 1
　　　　　　　　Worksheets("Sheet1").Range("A" & i & ":C" & i).Copy _
　　　　　　　　　　Worksheets(myK).Range("A" & myRow & ":C" & myRow)
　　　　　　End If
　　　　Next i
　　Set myDic = Nothing
End Sub

実行後は下記のようにデータが振り分けられます。
- Sheet1の元データ
- 実行後の各シート
  Sheet「果物」
  
  Sheet「野菜」

Dictionaryと配列を利用して処理する

元データを配列に読み込んでから処理します。
元データの全てを配列に読み込めるというのが前提条件になります。
Dictionaryで重複しない項目を取り出します。
振り分け先のシートが存在するか否かを調べます。
- シートがある場合はデータをいったん削除し、初期状態(列見出しのみを作成する)にします。
- シートがない場合はシートを追加して、初期状態(列見出しのみを作成する)にします。
データを順次転記します。ここで配列を利用しているので、処理速度は速くなります。

【コード例A】

標準モジュールに下記コードを入力（コピー&貼り付け）して、実行します。

ほとんど上と同じコードです。

Sub test3()
　　Dim myDic As Object, myKey
　　Dim c, myVal
　　Dim i As Long, j As Long
　　Dim mySh As Worksheet
　　Dim myFlg As Boolean
　　Dim lastRow As Long, myRow As Long
　　Dim myK As String
　　　　Set myDic = CreateObject("Scripting.Dictionary")
　　　　' ---(1)元データを配列に格納
　　　　lastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
　　　　myVal = Worksheets("Sheet1").Range("A2", "C" & lastRow).Value
　　　　' ---(2)myDicへデータを格納
　　　　For i = 1 To UBound(myVal)
　　　　　　If Not myVal(i, 2) = Empty Then
　　　　　　　　If Not myDic.Exists(myVal(i, 2)) Then
　　　　　　　　　　myDic.Add myVal(i, 2), ""
　　　　　　　　End If
　　　　　　End If
　　　　Next i
　　　　myKey = myDic.Keys
　　　　'----シートの有無を確認、なければ最後部に追加
　　　　For i = 0 To myDic.Count - 1
　　　　　　For Each mySh In Worksheets
　　　　　　　　myFlg = False
　　　　　　　　If mySh.Name = myKey(i) Then
　　　　　　　　　　myFlg = True
　　　　　　　　　　mySh.Cells.Delete
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next mySh
　　　　　　If myFlg = False Then
　　　　　　　　ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myKey(i)
　　　　　　End If
　　　　　　Worksheets("Sheet1").Range("A1:C1").Copy Worksheets(myKey(i)).Range("A1")
　　　　Next i
　　　　'----配列からデータを転記する
　　　　For i = 1 To UBound(myVal)
　　　　　　If myVal(i, 2) <> "" Then
　　　　　　　　myRow = Worksheets(myVal(i, 2)).Range("A" & Rows.Count).End(xlUp).Row + 1
　　　　　　　　For j = 1 To 3
　　　　　　　　　　Worksheets(myVal(i, 2)).Cells(myRow, j).Value = myVal(i, j)
　　　　　　　　Next j
　　　　　　End If
　　　　Next i
　　Set myDic = Nothing
End Sub

実行後は下記のようにデータが振り分けられます。
- Sheet1の元データ
- 実行後の各シート
  Sheet「果物」
  
  Sheet「野菜」

【コード例B】

標準モジュールに下記コードを入力（コピー&貼り付け）して、実行します。

ほとんど上と同じコードです。

キーとする項目(列)と最終行を変数に変えて、ちょっとだけ汎用性を高めたものです。
なお、数値でデータを振り分ける場合はシート名を文字列にする必要があると思います。
が数値になるため、書き出し部分では　Worksheets(CStr(myKey(i)))　といった修正が必要になります。
データを書き出す際にも配列で処理していますので、処理が上より早くできるはずです。

Sub test4()
　Dim myDic As Object, myKey
　Dim myVal, x
　Dim i As Long, j As Long, k As Long
　Dim mySh As Worksheet
　Dim myFlg As Boolean
　Dim lastRow As Long, lastCol As Long
　Dim myL As Integer
　Dim myCnt As Long
　　' ---(1)元データを配列に格納
　　lastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
　　lastCol = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
　　myVal = Worksheets("Sheet1").Range(Cells(2, 1), Cells(lastRow, lastCol)).Value
　　'----キーとする列を指定
　　myL = 2 '----B列をキーとしています、キーがA列なら　myL = 1 とします(2016/4/19修正しました）
　　' ---(2)myDicへデータを格納
　　Set myDic = CreateObject("Scripting.Dictionary")
　　For i = 1 To UBound(myVal)
　　　　If Not myVal(i, myL) = Empty Then
　　　　　　If Not myDic.Exists(myVal(i, myL)) Then
　　　　　　　　myDic.Add myVal(i, myL), 1
　　　　　　Else
　　　　　　　　myDic(myVal(i, myL)) = myDic(myVal(i, myL)) + 1
　　　　　　End If
　　　　End If
　　Next
　　myKey = myDic.Keys
　　'----シートの有無を確認、なければ最後部に追加
　　For i = 0 To myDic.Count - 1
　　　　For Each mySh In Worksheets
　　　　　　myFlg = False
　　　　　　If mySh.Name = myKey(i) Then
　　　　　　　　myFlg = True
　　　　　　　　mySh.Cells.Delete
　　　　　　　　Exit For
　　　　　　End If
　　　　Next mySh
　　　　If myFlg = False Then
　　　　　　ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myKey(i)
　　　　End If
　　　　'----値を各シートへ転記
　　　　With Worksheets("Sheet1")
　　　　　　.Range(.Cells(1, 1), .Cells(1, lastCol)).Copy Worksheets(myKey(i)).Range("A1")
　　　　End With
　　　　myCnt = 0
　　　　ReDim x(1 To lastRow, 1 To lastCol)
　　　　For k = 1 To UBound(myVal)
　　　　　　If myVal(k, myL) = myKey(i) Then
　　　　　　　　myCnt = myCnt + 1
　　　　　　　　For j = 1 To lastCol
　　　　　　　　　　x(myCnt, j) = myVal(k, j)
　　　　　　　　Next j
　　　　　　End If
　　　　Next k
　　　　Worksheets(myKey(i)).Cells(2, 1).Resize(UBound(x), lastCol).Value = x
　　　　Erase x
　　Next i
　　Set myDic = Nothing
End Sub

実行後は下記のようにデータが振り分けられます。
- Sheet1の元データ
- 実行後の各シート
  Sheet「果物」
  
  Sheet「野菜」

スポンサードリンク

よねさんのWordとExcelの小部屋｜Excel(エクセル) VBA入門：目次｜データ振り分ける

PageViewCounter
　 Counter
　Since2006/2/27