EXCELVBA データを自動で別シートにわける

質問

お世話になります。

昨日も同じよう質問にご回答いただいての、再度の質問で大変縮なのですが。。

添付の様な表があります。

このシートのどこかに「ボタン」を作成してこのボタンを押すと、支店(B列)毎に支店名が付いたシートを作成して、それぞれのデータも該当支店のシートへコピーペーストしたいのです。

どなたかお知恵をお借りできませんでしょうか。
恐れ入りますが、よろしくお願い致します。

環境 EXCEL2013　　Windows7

回答No.1

keithin · ベストアンサー

同じ手順で標準モジュールを用意、下記をコピー貼り付ける

sub macro2()
　dim h as range
　on error goto errhandle
　worksheets("元データのシート名").select 　’２度目。シート名は？

’転記する
　for each h in range("B2:B" & range("B65536").end(xlup).row)
　　h.entirerow.copy worksheets(h.value).range("A65536").end(xlup).offset(1)
　next
　exit sub

errhandle:
’支店名シートを新調する
　worksheets.add after:=worksheets(worksheets.count)
　activesheet.name = h.value
　worksheets("元データのシート名").range("1:1").copy range("A1")
　resume
end sub

シートにボタン絵柄を作成し、右クリックしてマクロを登録する。

お礼

keithinさん、ご連絡ありがとうございました。

何度もご丁寧なご説明ありがとうございました。
おかげさまで今回も希望通りの集計ができました。

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

回答No.3

tom04

No.2です。

＞このシートのどこかに「ボタン」を作成してこのボタンを押すと・・・
を見逃していました。
メニュー　→　開発　→　挿入のアイコン　→　ActiveXの「コマンドボタン」が良いと思います。を挿入　→　そのコマンドボタン上でダブルクリック
＞Private Sub CommandButton1_Click()
と
＞End Sub
の間に
前回のコードの
＞Sub Sample1() 'この行から
と
＞End Sub 'この行まで
以外をコピー＆ペースト　→　デザインモードを解除して、コマンドボタンをクリックしてみてください。

※　別にコマンドボタンでなくても、オートシェイプ等を使って「マクロの登録」でも可能です。

どうも失礼しました。m(_ _)m

お礼

tom04さん、ご連絡いただきまして誠にありがとうございます！！

希望通りの動きが出来ました！！
本当にありがとうございました。

いつも詳細なご説明いただきまして誠にありがとうございます。

回答No.2

tom04

こんばんは！
一例です。
標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

尚、元データはSheet1（Sheet見出しの一番左側にあるとします）

Sub Sample1() 'この行から
Dim i As Long, k As Long, wS As Worksheet
Application.ScreenUpdating = False
If Worksheets.Count > 1 Then
Application.DisplayAlerts = False
For k = Worksheets.Count To 2 Step -1
Worksheets(k).Delete
Next k
End If
Worksheets.Add after:=Worksheets(1)
Set wS = Worksheets(2)
With Worksheets(1)
.Range("B:B").AdvancedFilter , Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To Worksheets(2).Cells(Rows.Count, "A").End(xlUp).Row
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = wS.Cells(i, "A")
.Range("A1").AutoFilter field:=2, Criteria1:=wS.Cells(i, "A")
.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Worksheets(Worksheets.Count).Range("A1").PasteSpecial Paste:=xlPasteAll
Next i
.AutoFilterMode = False
wS.Delete
Application.DisplayAlerts = True
.Activate
.Range("A1").Select
End With
Application.ScreenUpdating = True
End Sub 'この行まで

※　一旦Sheet1以外は削除するようにしていますので、
念のため、別Bookでマクロを試してみてください。m(_ _)m