エクセルのグループ名ごとに別シートを作成するマクロについて

Question

普段VBAを全く使わない初心者で申し訳ありません。
年度初めに作成したいものがあります。

下のシートのようなものがあり、これをグループ「ア」だけで名前と住所が入ったシート、「イ」だけで名前と住所が入ったシートを新規作成していくプログラムを教えていただきたいです。
なお、グループ名は１０グループ程になる予定です。

よろしくお願いいたします。

ママチャリ · Accepted Answer

こんな感じでどうでしょう。元データのシート名は、Sheet1としています。

Sub sample()
    Dim ws As Worksheet
    Dim I As Long
    '元シートをコピーし作業用シートを作成。グループでソート＆重複を削除する。
    Sheets("Sheet1").Copy After:=Sheets(1)
    Set ws = ActiveSheet
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("C:C"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A:C")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ws.Range("A:C").RemoveDuplicates Columns:=3, Header:=xlYes
    'グループ毎のシート生成。
    For I = 2 To ws.UsedRange.Rows.Count
        If ws.Cells(I, 3) = "" Then Exit For
        Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
        With ActiveSheet
            .Range("A:C").AutoFilter Field:=3, Criteria1:="<>" & ws.Cells(I, 3), _
                Operator:=xlAnd
            .Rows("2:" & .UsedRange.Rows.Count).Delete Shift:=xlUp
            .Range("A:C").AutoFilter
            
            .Name = ws.Cells(I, 3)
        End With
    Next I
    '作業用シートの削除。
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
End Sub

tom04 · Answer

こんばんは！

すでに回答は出ていますので、参考程度で・・・
標準モジュールです。

Sub Sample1()
    Dim i As Long, k As Long, myCol As Long
    Dim sN As String, wS As Worksheet, myFlg As Boolean
    Application.ScreenUpdating = False
    With Worksheets(1)
        myCol = .Cells(1, Columns.Count).End(xlToLeft).Column + 2
        .Range("C:C").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Cells(1, myCol), unique:=True
        .Columns(myCol).Sort key1:=.Cells(1, myCol), order1:=xlAscending, Header:=xlYes
        For i = 2 To .Cells(Rows.Count, myCol).End(xlUp).Row
        For k = 2 To Worksheets.Count
            If Worksheets(k).Name = .Cells(i, myCol) Then
                myFlg = True
                Exit For
            End If
        Next k
            If myFlg = False Then
                Worksheets.Add after:=Worksheets(Worksheets.Count)
                Worksheets(Worksheets.Count).Name = .Cells(i, myCol)
            End If
            sN = .Cells(i, myCol)
            Set wS = Worksheets(sN)
            myFlg = False
            wS.Move after:=Worksheets(i - 1)
            wS.Cells.Clear
            With .Range("A1").CurrentRegion
                .AutoFilter field:=3, Criteria1:=.Cells(i, myCol)
                .SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
            End With
        Next i
        .AutoFilterMode = False
        .Columns(myCol).Clear
    End With
    Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m

hallo-2007 · Answer

私だったら、グループの数のシートは作成しませんね。
一例ですが、別途　シートに
　A　 　　B　　　C
名前　　住所　　グループ
　　　　　　　　　ア
と云ったシートを準備して

C2セルにグループ名を入力したら
A,B列が表示される仕組みを考えます。
関数でも出来ますが、フィルターオプションの機能が便利です。
http://www4.synapse.ne.jp/yone/excel2010/excel2010_filter21.html
を参考にしてみてください。
コードは、マクロの記録で簡単に作成できます。
次に、シートモジュールの
Private Sub Worksheet_Change(ByVal Target As Range)
・・・・
End Sub
にコピーすれば、C2セルを変更すると瞬時に希望の一覧になります。
シートは２枚で十分です。
マクロのコードも数行で可能です。

エクセルのグループ名ごとに別シートを作成するマクロについて

こんな感じでどうでしょう。

こんばんは！

私だったら、グループの数のシートは作成しませんね。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング