【マクロ・VBA　コード・ファイルダウンロード可】表データをカテゴリー毎にSheetを一括作成する

表データをカテゴリー毎にSheetを一括作成するマクロファイルを作りました

ファイルダウンロードができますので良かったら試してみてください

またコードの紹介もしています

使い方の動画↓

仕事に置いて表データをカテゴリー毎に分ける場合って結構ありますよね？

でもここで問題なのは、この作業結構大変なんですよね

フィルターを使ってカテゴリー分けをして、それ用のSheetを作り

Sheet間を行ったり来たりしてコピペを繰り替えす

時間が限られる中で、この作業をするのはもったいないです

なによりミスが起きる可能性も高いです

このマクロを使って仕事を楽にしちゃいましょう

ファイルダウンロード
コード

ファイルダウンロード

ファイルです→カテゴリー毎にSheet一括作成.xlsm

※インターネットからのマクロは、Office では既定でブロックされますので許可する必要があります

詳細はマイクロソフトが公開してますので参考にしてください →詳細ページ

ファイルダウンロードがちょっと怖いという方はコードをコピペして使ってください

ファイルを開くと黄色タスクバーが出てくるので、「編集を有効にする」を押すと

今度は赤色のタスクバーがでできます「詳細を表示」を押してもうまく動かせないので
次の操作をしてください

使いたいファイルの「プロパティ」を開きます

赤枠の中の「許可する（K）」にチェックを入れて「適用」をクリックしてください

すると赤枠がなくなるので使えるようになります

コード

Sheet作成用コード

Sub sheet作成()
'変数//////////////////////////////////////////////
Dim ary_全 'データの配列用変数

Dim wb As Workbook: Set wb = ThisWorkbook 'このbook用変数

Dim ws_全 As Worksheet: Set ws_全 = wb.Sheets("全データ") '「全データ」シート用変数

Dim ws As Worksheet 'シートのカウンター変数

Dim i, j, c 'カウンター変数

Dim last_r '最終行用変数

'データ配列化/////////////////////////////////////
ary_全 = ws_全.Range("A1").CurrentRegion

'空白の確認→「カテゴリーなし」代入///////////////
For i = 2 To UBound(ary_全, 1)
    
    If IsEmpty(ary_全(i, 1)) = True Then '空白の時
        
        ary_全(i, 1) = "☆カテゴリーなし☆"
    
    End If

Next i

'Sheet作成////////////////////////////////////////
For i = 2 To UBound(ary_全, 1)
    
    c = 0
    
    For Each ws In wb.Sheets
        
        If ws.Name = ary_全(i, 1) Then 'A列のSheet名とこのBookのシート名を照合
            
            c = 1 '同じシート名がある場合、cに1を入れる
        
        End If
    
    Next
        
        If c = 0 Then '同じシート名がない時
            
            Sheets.Add after:=wb.Sheets(wb.Sheets.Count) 'Sheetを末尾に作成
            
            ActiveSheet.Name = ary_全(i, 1) 'シート名を入れる
            
            For j = 1 To UBound(ary_全, 2)
                
                ActiveSheet.Cells(1, j) = ary_全(1, j) '1行目見出しを代入
            
            Next j
        
        End If

Next i

'☆カテゴリーなし☆を末尾に移動////////////////////////////////////////
For Each ws In wb.Sheets
        
        If ws.Name = "☆カテゴリーなし☆" Then '☆カテゴリーなし☆のシート名の時
            
            ws.Move after:=wb.Sheets(wb.Sheets.Count) '末尾に移動
        
        End If
    
    Next

'データをそれぞれのシートに分ける///////////////////////////////////////
For i = 2 To UBound(ary_全, 1)
    
    For Each ws In wb.Sheets
        
        If ws.Name = ary_全(i, 1) Then 'シート名とA列の値が同じとき
            
            last_r = ws.Cells(Rows.Count, 1).End(xlUp).Row '該当のシートの最終行を取得
            
            For j = 1 To UBound(ary_全, 2)
            
                ws.Cells(last_r + 1, j) = ary_全(i, j) '最終行の1つしたの行に代入
            
            Next j
            
        End If
    
    Next
    
Next i

ws_全.Activate
MsgBox "終了"
End Sub

初期化コード

Sub 初期化()
'変数//////////////////////////////////////////////
Dim wb As Workbook: Set wb = ThisWorkbook 'このbook用変数

Dim ws_全 As Worksheet: Set ws_全 = wb.Sheets("全データ")

Dim ws As Worksheet 'シートのカウンター変数

Dim yesno As String 'メッセージBOX用変数

'削除の確認///////////////////////////////////////

yesno = MsgBox("初期化しますか？", vbYesNo, "確認") '初期化の確認

If yesno = 7 Then 'いいえの時は、マクロを終了させる
    Exit Sub
End If

'先頭行以外削除////////////////////////////////////
ws_全.Range("A1").CurrentRegion.Offset(1).ClearContents '「全シート」の先頭行以外削除

ws_全.Range("A:A").Interior.Color = 65535 'A列塗りなおし

'全シート以外削除/////////////////////////////////

Application.DisplayAlerts = False '警告表示を非表示設定

For Each ws In wb.Sheets
    If ws.Name <> "全データ" Then '「全シート」以外を削除
        ws.Delete
    End If
Next

Application.DisplayAlerts = True '警告表示を表示設定
End Sub

※うまく動かない場合はコメントでください