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

質問

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

回答No.4

deecyan · ベストアンサー

>こんな単純な修正ではいけないのでしょうか…。
はい　元にもどしてください

1行目に何か文字があると前提で、下記の変更でできると思います。

-----
Set us = ActiveSheet.UsedRange
を
Set hdr = Rows("1:3")
Set us = Range(Cells(4, ActiveSheet.UsedRange.Column), _
Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
に
-----
Call AddNewSheets(UniqueArray(rn, 1), us, CodeIndex)
を
Call AddNewSheets(UniqueArray(rn, 1), us, CodeIndex, hdr)
に
-----
Sub AddNewSheets(NewName As Variant, us As Range, CodeIndex As Integer)
を
Sub AddNewSheets(NewName As Variant, us As Range, CodeIndex As Integer, hdr)
に
-----
Set AnotherSheet = Worksheets.Add
の後に
hdr.Copy (AnotherSheet.Cells(1, 1))
を追加してみてください

お礼

回答ありがとうございます。
お礼が遅くなって申し訳ございません。
教えていただいたとおりやってみました。
できました。
ほんとにどうもありがとうございました！

回答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

回答No.2

haruka1234567890

表のイメージがつかめない。

・項目はどのような括りなっているのですか？
・５行目以降のセル配置を教えてください。
・新シートへはタイトル（１から４行目）部分もコピーするのですか。

補足

回答ありがとうございます。
言葉足らずですみません…。
シート１枚の名簿を部署ごとにわけて、タイトル（１から４行目）部分もコピーしながら、それぞれの新しいシートを作るような感じです。

下記ようなマクロをもらったので、列を検索する部分の
For rn = 2 To UBound(UniqueArray)　を
For rn = 5 To UBound(UniqueArray)　にかえて、

Call AddNewSheets(UniqueArray(rn, 1), 　を
Call AddNewSheets(UniqueArray(rn, 1:4), に
してみたのですが、
For rn = 5 To UBound(UniqueArray)
でエラーになってしまうのです…。
こんな単純な修正ではいけないのでしょうか…。
VBAの知識はぜんぜんないのでどう修正したらよいのかわからないのです…。
すみませんが教えてください。

Sub シート別分類()
Dim us As Range
Dim CodeIndex As Integer
Dim UniqueArray As Variant
Dim rn As Integer

Set us = ActiveSheet.UsedRange
'分類する項目（列）を指定
CodeIndex = Application.InputBox( _
"振り分ける項目を選択してください", "シート別分類", _
, , , , , 8).Column
UniqueArray = GetUniqueArray(us, CodeIndex)
'振り分ける項目第2要素から最終要素まで(第1は見出しとして除く)
For rn = 2 To UBound(UniqueArray)
Call AddNewSheets(UniqueArray(rn, 1), us, CodeIndex)
Next
Application.StatusBar = False

us.AutoFilter
End Sub

回答No.1

imogasi

エクセルのメニューの「ウィンドウ」の「ウインドウ枠の固定」で出来ることでしょうか。
そうであればなぜ、「ツール」「マクロ」「新しいマクロの記録」を取らないのでしょうか。