アクティブシートのリストを
指定した列の値ごとに
分割してシートに分けるマクロ
コード
Sub リスト分割応用() Dim c As Long Dim r As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim listLastRow As Long Dim filterColumn As Range Dim filterValue As String Dim lastRow As Long Dim i As Long Dim ii As Long Dim iii As Long c = InputBox("対象の列が何行目か入力してください" & vbCrLf & "(C列の場合の入力例:3)") r = InputBox("タイトルとして残したい行を入力してください" & vbCrLf & "(入力例:2)") ' アクティブシートを大元のワークシートとして指定 Set ws1 = ActiveSheet ' フィルターをクリア ws1.AutoFilterMode = False 'リストシートを作成 Set ws2 = Sheets.Add ws1.Columns(c).Copy Destination:=ws2.Range("A1") 'リストシートのタイトル行を削除 For ii = 1 To r ws2.Cells(1, ii).EntireRow.Delete Next ii 'リストシートの重複を削除 ws2.Range("A1").CurrentRegion.RemoveDuplicates Columns:=1 listLastRow = ws2.Range("A1").CurrentRegion.Rows.Count '繰り返しの指定 For i = 1 To listLastRow ' フィルターの条件を指定(指定の文字列以外を削除) filterValue = ws2.Cells(i, 1) '大元のシートを、最後にコピーする ws1.Copy After:=Worksheets(Worksheets.Count) 'コピーしたシートをws3とする Set ws3 = Worksheets(Worksheets.Count) ' フィルターをかける列を指定 Set filterColumn = ws3.Cells(1, c).EntireColumn ' 最終行を取得 lastRow = ws3.Cells(ws3.Rows.Count, filterColumn.Column).End(xlUp).Row ' オートフィルターモードを有効にしてフィルターを設定 filterColumn.AutoFilter Field:=1, Criteria1:="<>" & filterValue ' フィルターされた行を削除 For iii = lastRow To r + 1 Step -1 If Not ws3.Cells(iii, filterColumn.Column).EntireRow.Hidden Then ws3.Rows(iii).Delete End If Next iii ' オートフィルターモードをクリア ws3.AutoFilterMode = False 'ワークシートの名前を変える ws3.Name = filterValue Next i 'リストシートを削除 Application.DisplayAlerts = False ws2.Delete MsgBox "分割完了" End Sub
利用方法詳細
列は必ず数字で指定すること。
※列選択のときに何も入力されていない列を選ぶとエラーになる。
タイトル行も指定できるコードなので
タイトルとして2行目まで残したい場合にも利用できる
6列目の性別で分割、タイトルは2行目まで残した場合
いろんな場面で使える汎用性の高いコード。
列とタイトル行を固定したい場合は以下を参照。
sacu.sacu-ri.com