Ｅｘｃｅｌでの帳票作成

質問

Ｅｘｃｅｌで以下のようなシートがあります。

---------------------------
A列　 B列 C列 D列
1 Name1 11111 2222 3333
2 Name1 44444 5555 6666
3 Name1 77777 8888 9999
4 Name2 aaaaa bbbb cccc
5 Name2 ddddd eeee ffff
6 Name3 ggggg hhhh iiii
---------------------------
これを元に以下のようなシートを別々に作成したいです。

＜シート1＞
Name1 11111 3333
Name1 44444 6666
Name1 77777 9999

＜シート2＞
Name2 aaaaa cccc
Name2 ddddd ffff

＜シート3＞
Name3 ggggg iiii

つまり、元のシートのA列の内容(Name1,Name2,Name3)毎にシートを
作成し、A列、B列、C列をコピーしたいです。

上記のシート作成をマクロで自動化したいのですが、どのように行えばよいでしょうか？
（ＶＢＡでも可）

以上、よろしくお願いします。

回答No.6

Wendy02 · ベストアンサー

こんにちは。Wendy02です。

何度か、同じものは作っていたのですが、今回は、最初からアドイン変更可能なマクロを作ってみました。つまり、アクティブブックですから、必ずしも、マクロは、同じブックになくても可能です。新規ブックにデータを写して、実行しても可能です。

ただし、今の段階では、一番左端のシート(一般的には、Sheet1ですが、名前は関係がありません)のA1 からデータがあることになっています。ですから、もしも、そうでない場合は、「Set rng = sh1.Range("A1").CurrentRegion 」の部分を、「Set rng = ActiveCell.CurrentRegion 」としてください。また、項目行はあることを条件として作られています。

なお、追加がある場合は、そのまま実行してしまってください。最初からやり直して、上書きされます。

注意：データはSheet2(左端から２番目のシート) から入れてしまっていますから、もしも、データがある場合は、上書きされてしまいます。

Sub SplitData2Sheets()
'アドイン変更可
　Dim sh1 As Worksheet
　Dim rng As Range
　Dim Acwb As Workbook　'アクティブブック対象

　Dim i As Integer
　Dim j As Integer

　On Error GoTo EndLine
　Set Acwb = ActiveWorkbook

　Set sh1 = Acwb.Worksheets(1) 'ソースになるシート
　sh1.Activate '通常は不要ですが、ActiveCell とした場合に必要になる
　Set rng = sh1.Range("A1").CurrentRegion 'データの左上端
　If rng.Rows.Count < 2 Then
　　 MsgBox "データが不足しているか、データの場所が違うかもしれません。", vbInformation
　　 GoTo EndLine
　End If
　If sh1.AutoFilterMode = True Then
　　sh1.AutoFilterMode = False
　End If
　Application.ScreenUpdating = False
　With rng
　　'ユニークデータの抽出
　　rng.Columns(1).AdvancedFilter _
　　　　　 Action:=xlFilterCopy, _
　　　　　 CopyToRange:=Range("IV1"), _
　　　　　 Unique:=True

　　'ユニークデータ数(項目行を含める=シートの数+1)
　　j = sh1.Range("IV1", sh1.Range("IV65536").End(xlUp)).Count
　　If j > Acwb.Worksheets.Count Then
　　　Acwb.Worksheets.Add After:=Acwb.Worksheets(Acwb.Worksheets.Count), Count:=(j - Acwb.Worksheets.Count)
　　End If
　　'項目行があるので、2行目
　　'シート2　から-もしも、他のシートからの場合は、上記のj に数を足す
　　For i = 2 To j
　　　.AutoFilter
　　　.AutoFilter Field:=1, Criteria1:=CStr(sh1.Cells(i, 256).Value)
　　　If .SpecialCells(xlCellTypeVisible).Count > 1 Then
　　　　.Rows(1).Copy Acwb.Worksheets(i).Range("A1")
　　　　.Offset(1).Resize(.Count - 1).Copy Acwb.Worksheets(i).Range("A2")
　　　　Acwb.Worksheets(i).Name = CStr(sh1.Cells(i, 256).Value)
　　　End If
　　Next i
　End With
　Application.ScreenUpdating = True
EndLine:
　If Err.Number > 0 Then
　　 MsgBox Err.Number & " : " & Err.Description
　End If
　With sh1
　　.AutoFilterMode = False
　　.Range("IV1", sh1.Range("IV65536").End(xlUp)).Clear
　　.Select
　End With
　Set rng = Nothing
　Set sh1 = Nothing
　Set Acwb = Nothing

End Sub

お礼

ご回答ありがとうございます。

こちらも試させて頂いたのですが、希望通りに動きました！

フィルターを使って、このようなことができるとは知りませんでした。
このマクロだと、Ａ列の値が万一バラバラに入っていても大丈夫ですね。

本当に助かりました。ありがとうございます。

回答No.5

ham_kamo

No.3です。
１行目からデータが入力されると処理がちょっとややこしくなり、そのつもりでマクロを書いたのですが、１行目はタイトル行なのですね？
それを踏まえて、マクロを修正しました。２行目からデータを走査し、シートを追加したときに新しいシートの１行目に元データのシートと同じタイトルをつけるようにしました。
作成するシートにタイトル行が不要であれば、下のマクロの「'２行目から転記」とコメントがある行を
rownum = 1
と修正して、それ以下３行を削除してください。

Sub 帳票作成()
　　Dim S As Worksheet
　　Dim CS As Worksheet
　　Dim rownum As Integer
　　Dim r As Range
　　Set S = Worksheets("Sheet1")
　　For Each r In S.Range("A2", S.Range("A65535").End(xlUp))
　　　　If r.Value <> r.Offset(-1, 0).Value Then
　　　　　　Set CS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
　　　　　　CS.Name = r.Value
　　　　　　rownum = 2 '２行目から転記
　　　　　　CS.Range("A1") = S.Range("A1") 'タイトル行コピー
　　　　　　CS.Range("B1") = S.Range("B1") 'タイトル行コピー
　　　　　　CS.Range("C1") = S.Range("D1") 'タイトル行コピー
　　　　End If
　　　　CS.Cells(rownum, 1) = r.Value
　　　　CS.Cells(rownum, 2) = r.Offset(0, 1).Value
　　　　CS.Cells(rownum, 3) = r.Offset(0, 3).Value
　　　　rownum = rownum + 1
　　Next
End Sub

お礼

わざわざ修正していただき、ありがとうございました。

試してみましたが、希望通りの動きでした。

本当に助かりました。ありがとうございます。

回答No.4

Wendy02

こんにちは。

探せば、そっくり同じようなコードは出てくるような気がします。
こういう処理は、考え方はいろいろあっても、マクロ(VBA)に限るかと思います。AutoFilter を使用して、コピーしていきます。

ただ、いくつか問題があります。

以下のように１行目から使われてしまうと、マクロですと、難しくなります。仮にでもよいので、項目行が必要です。

---------------------------
A列　 B列 C列 D列
1 Name1 11111 2222 3333　　←ここに項目行(フィールド)がありません。
2 Name1 44444 5555 6666
3 Name1 77777 8888 9999
4 Name2 aaaaa bbbb cccc
5 Name2 ddddd eeee ffff
6 Name3 ggggg hhhh iiii
---------------------------

また、追加処理をするのかどうか、という問題もありますね。

＜シート1＞　←シート1ということはないと思います。
Name1 11111 3333
Name1 44444 6666
Name1 77777 9999
***　←ここに追加が加わるかどうか。

シート1は、ソース(元のデータ)用に使います。
ソースに、データを追加していって、それを振り分ける必要があるのか、ということです。また、追加の場合は、データの重複を許すのか、ということもありますね。

>元のシートのA列の内容(Name1,Name2,Name3)毎にシートを作成し、
とありますが、100も200も作るというわけには行きません。私自身の経験では、データ量にもよりますが、一般的な使用範囲としては、40枚前後が限界ではないか、と思っています。

マクロを専門に書く側では、もう少し情報がないと、思ったようにはいかないと思います。

補足

ご回答ありがとうございます。
情報が不足していて申し訳ありませんでした。

>以下のように１行目から使われてしまうと、マクロですと、難しくなります。仮にでもよいので、項目行が必要です。
実際のシートには１行目に項目名があります。

>＜シート1＞　←シート1ということはないと思います。
済みません。ご指摘の通りシート名はＡ列の内容（Name1など）にしたいです。

>ソースに、データを追加していって、それを振り分ける必要があるのか、ということです。また、追加の場合は、データの重複を許すのか、ということもありますね。
基本的にソースに追加することありません。ある時点で凍結したソースを元に質問内容のシートを追加していきたいと考えています。
データについては重複を許しています。

>私自身の経験では、データ量にもよりますが、一般的な使用範囲としては、40枚前後が限界ではないか、と思っています。
最大で２０個くらいですので、なんとかなる範囲なのですね。

上記を踏まえ、AutoFilterを使用しての実現方法をお教えいただけたらと思います。

よろしくお願い致します。

回答No.3

ham_kamo

こんな感じでしょうか。
マクロの中の"Sheet1"という部分は、実際に元となるシートの名前に置きかえてください。

Sub 帳票作成()
　　Dim S As Worksheet
　　Dim CS As Worksheet
　　Dim rownum As Integer
　　Dim r As Range
　　Set S = Worksheets("Sheet1")
　　For Each r In S.Range("A1", S.Range("A65535").End(xlUp))
　　　　If r.Row = 1 Then
　　　　　　Set CS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
　　　　　　CS.Name = r.Value
　　　　　　rownum = 1
　　　　ElseIf r.Value <> r.Offset(-1, 0).Value Then
　　　　　　Set CS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
　　　　　　CS.Name = r.Value
　　　　　　rownum = 1
　　　　End If
　　　　CS.Cells(rownum, 1) = r.Value
　　　　CS.Cells(rownum, 2) = r.Offset(0, 1).Value
　　　　CS.Cells(rownum, 3) = r.Offset(0, 3).Value
　　　　rownum = rownum + 1
　　Next
End Sub

補足

ご回答ありがとうございます。
行とその上の行を比較して、差異があれば新たにシートを作るのですね！

大変勉強になりました。
これから、別件で席をはずすので、戻ってから試してみたいと思います。
結果はそのときご報告させて頂きます。

回答No.2

Cupper

マクロを使う必要はあるのでしょうか

元のシートは1つだけで、それを簡単に振り分けたいのであればマクロを作成するまでもなく、オートフィルタで十分です。

また、同じような元シートがたくさんある、振り分ける項目が多数あるなど、その振分けに困っているのであれば手順を記録する自動記録マクロで十分事足りると思います。

●以下手順
オートフィルタを設定
A列で表示する項目を選択
[ツール]→[マクロ]→[新しいマクロの記録]
　A列からC列を選択
　[編集]→[ジャンプ]→[セル選択]→「可視セル」のラジオボタンをクリック→[OK]
　[編集]→[コピー]
[ツール]→[マクロ]→[記録終了]
貼り付けたいシートを選択
[編集]→[貼り付け]

あとはA列のオートフィルタで表示する項目を選択した後に、
記録したマクロを実行して
貼り付けたいシートを選んで貼り付けを行うだけです。

元のシートが1つだけの場合はマクロの記録を行わなければOK。
完全自動化させたいのであれば、記録されたマクロを見ながら修正を行えば可能です。

補足

ご回答ありがとうございます。

実は元ファイルがかなり多くあり、またＡ列の内容も（フィルタをかける数）も多くひとつひとつ手作業ですることは難しい状況です。
仕様的には、別のあるファイルに作業するファイルのリストを作成、ボタンクリックでそのリストファイルすべてに対して質問内容を実行したいと考えています。
ファイルリストからファイルオープンさせたりすることは簡単なのですが、ファイルを開いた後、質問内容のように「自動的にＡ列の内容毎に、シートを作成する方法」がわかりません。
Ａ列の内容（Name1など）もシートによって違うので、"Name1"など内容を指定しての抽出もできません。

なお、Ａ列はその内容毎に上からまとまっていいます。
（Name1の行が連続してあり、Name2の後でまたName1が現れることはない）

初心者で徐々にステップアップしていくことが一番だとは承知しておりますが、月曜日にはある程度目処を立てないといけない状況ですので、アドバイスの方、よろしくお願い致します。

回答No.1

popesyu

オートフィルタを有効にして、D列を非表示にしてしまえば、わざわざマクロに頼らなくても実現可能だと思いますが。
マクロだとワンクリックですみますが、オートフィルタならスリークリックかかるというぐらいの差しかないです。
どうしても別シートにする必要があるのなら、その作業をマクロの自動記録で保存して、そのまま実行するだけでも出来ますし。

具体的にコードのどういう部分が分からないというレベルでも無さそうですし、初心者さんであればあるほど、いきなりサンプルコードを提示してもらうのではなく、今現在の知識で出来るところからコツコツとやるべきかと。

補足

ご回答ありがとうございます。
実は元ファイルがかなり多くあり、またＡ列の内容も（フィルタをかける数）も多くひとつひとつ手作業ですることは難しい状況です。
仕様的には、別のあるファイルに作業するファイルのリストを作成、ボタンクリックでそのリストファイルすべてに対して質問内容を実行したいと考えています。
ファイルリストからファイルオープンさせたりすることは簡単なのですが、ファイルを開いた後、質問内容のように「自動的にＡ列の内容毎に、シートを作成する方法」がわかりません。
Ａ列の内容（Name1など）もシートによって違うので、"Name1"など内容を指定しての抽出もできません。

なお、Ａ列はその内容毎に上からまとまっていいます。
（Name1の行が連続してあり、Name2の後でまたName1が現れることはない）

初心者で徐々にステップアップしていくことが一番だとは承知しておりますが、月曜日にはある程度目処を立てないといけない状況ですので、アドバイスの方、よろしくお願い致します。