【エクセル】シートを分割するマクロを教えてください

質問

1行目から4行目までをタイトルに使用している1枚のシートを、選択した列の5行目以降に含まれている項目ごとにまとめて、それぞれのシートを作成したいのですが、どうしたらよいのでしょうか。
どなたか教えてください。
よろしくお願いします。

回答No.3

deecyan

これだけでは分かりませんね

AddNewSheets　のサブルーチン
と　GetUniqueArrayのファンクション
は長いですか？　提示してもらえませんか？

補足

回答ありがとうございます。
続きを提示させていただきます。
よろしくお願いいたします…。

Sub AddNewSheets(NewName As Variant, us As Range, CodeIndex As Integer)
Dim AnotherSheet As Worksheet

Application.StatusBar = NewName & "について検索中"
us.AutoFilter Field:=CodeIndex, Criteria1:=NewName
Set AnotherSheet = Worksheets.Add
us.SpecialCells(xlVisible).EntireRow.Copy (AnotherSheet.Cells(1, 1))
AnotherSheet.Name = NewName
End Sub

Function GetUniqueArray(us As Range, CodeIndex As Integer) As Variant
Dim NewSheet As Worksheet

Set NewSheet = Worksheets.Add
us.Columns(CodeIndex).AdvancedFilter _
Action:=xlFilterCopy, _
copyToRange:=NewSheet.Range("A1"), _
criteriaRange:=us.Columns(CodeIndex), _
Unique:=True
GetUniqueArray = NewSheet.UsedRange

Application.DisplayAlerts = False
NewSheet.Delete
Application.DisplayAlerts = True
End Function

Function UniqueDataCount(CodeIndex As Integer) As Long
Dim us As Range
Dim UniqueArray As Variant

Set us = ActiveSheet.UsedRange

us.Columns(CodeIndex).AdvancedFilter _
Action:=xlFilterCopy, _
copyToRange:=ActiveSheet.Range("G1"), _
criteriaRange:=us.Columns(CodeIndex), _
Unique:=True

End Function