フィルタで重複行を抽出→別シートに項目ごとの一覧表を作る【ExcelVBA】

はじめに

Excelで作った一覧表の、特定の項目別に表を作成したいと思ったことはないでしょうか？通常、エクセルのフィルタ機能を使えばこの操作を行うことが出来ますが、項目ごとにコピペで新たなシートに貼り付けたりするのは意外と大変です。

果物の受注一覧から、果物別に注文情報の一覧を作成します。

以下のイメージになります。

そこで今回は、一覧表から各項目ごとに別シートにまとめるマクロをご紹介したいと思います。処理の中で少しややこしいところが出てきますが、とりあえず全体の処理の流れを確認して、難しいところはまた別の機会に詳細をご説明したいと思います。

サンプルコード

それでは、まずサンプルコードをご紹介します。

Sub 重複一覧作成()

    ActiveSheet.Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=ActiveSheet.Range("F1"), Unique:=True
    
    Dim finalrow As Integer
    finalrow = ActiveSheet.Range("A1").End(xlDown).Row
        
    Dim keyarray() As String
    Dim lastrow As Integer
    
    lastrow = ActiveSheet.Range("F1").End(xlDown).Row
    
    ReDim keyarray(lastrow - 1)
    
    For i = 0 To lastrow - 1
        keyarray(i) = ActiveSheet.Cells(i + 2, 6)
    Next i
    
    For i = 0 To UBound(keyarray) - 1
    
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = keyarray(i)
        
        Worksheets(1).Rows(1).Copy
        Worksheets(keyarray(i)).Rows(1).PasteSpecial (xlPasteAll)
        
        Dim cnt As Integer
        cnt = 2
    
        For j = 2 To finalrow
            If Worksheets(1).Cells(j, 1) = keyarray(i) Then
                
                Worksheets(keyarray(i)).Rows(cnt).Insert
                Worksheets(1).Rows(j).Copy
                Worksheets(keyarray(i)).Rows(cnt).PasteSpecial (xlPasteAll)
                cnt = cnt + 1
            End If
        Next j
        Worksheets(keyarray(i)).Columns("F").Delete
    Next i
    Worksheets(1).Columns("F").Delete
        
    
End Sub

サンプルコード解説

それではコードを解説します。

フィルタで重複を抽出して一時的に使用しない列に保存する

ActiveSheet.Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=ActiveSheet.Range("F1"), Unique:=True

フィルタで「品名」の列から重複を取り除いた内容を抽出します。最後の引数にUnique:=Trueを指定することで可能になります。そして抽出した内容をF1セル以下に貼り付けます。この内容を使ってこのあとの処理を行います。

内容を取り出すキーとなる配列を作成する

    Dim keyarray() As String
    Dim lastrow As Integer
    
    lastrow = ActiveSheet.Range("F1").End(xlDown).Row
    
    ReDim keyarray(lastrow - 1)
    
    For i = 0 To lastrow - 1
        keyarray(i) = ActiveSheet.Cells(i + 2, 6)
    Next i

今回抽出する品名を格納した配列を作成します。配列形式にすることで、後ほどForループで各要素を取り出せるようにするためです。配列keyarrayは、重複する要素の数が変化するため、可変長の配列を宣言してReDimにより再度配列の大きさを再定義します。

新規シートを最後尾に追加し、品名の名前をつける

     For i = 0 To UBound(keyarray) - 1
    
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = keyarray(i)
        
        Worksheets(1).Rows(1).Copy
        Worksheets(keyarray(i)).Rows(1).PasteSpecial (xlPasteAll)
        

forループで品名ごとに処理を行います。ワークシートを最後尾に加えて、keyarrayから品名を取り出して名前をつけます。また、一行目に見出しを元シートからコピーして貼り付けます。

処理中の品名の行になったら、元シートからコピーして貼り付ける

        Dim cnt As Integer
        cnt = 2
    
        For j = 2 To finalrow
            If Worksheets(1).Cells(j, 1) = keyarray(i) Then
                
                Worksheets(keyarray(i)).Rows(cnt).Insert
                Worksheets(1).Rows(j).Copy
                Worksheets(keyarray(i)).Rows(cnt).PasteSpecial (xlPasteAll)
                cnt = cnt + 1
            End If
        Next j

forループで一覧を上から順位処理し、品名が現在処理中のkeyarrayに格納した品名の場合に元シートから新規シートにコピーして貼り付けます。forループが二重になっているので分かりづらいのですが、よく見ると処理が理解できると思います。
カウント変数cntは新規シートに挿入する行をカウントするカウンタ変数で、一行追加するごとにインクリメント（+1）されます。

フィルタで抽出した一時保存データを消去する

          Worksheets(keyarray(i)).Columns("F").Delete
       Next i
    Worksheets(1).Columns("F").Delete

“F”列に一時保存した抽出データを列ごと消去します。

おわりに

やっていることはそう難しくないのですが、繰り返しが多かったりしてちょっとむずかしいコードになているかもしれません。今回は実用性を考えて、一気にすべての処理をご紹介しましたが、この中にあるいくつかの処理は掘り下げて理解する必要があるものもあります。

次回以降、回を改めてそれらの細かな処理についてご紹介したいと思います。とりあえず今回のコードをお使いいただければ、やりたい処理をサクッと終わらせることができるのではないかと思います。