エクセルマクロ シートごとに分割

質問

編集の関係上、県別にシート分けをしたいのですが
マクロで出来ないでしょうか？
もし出来るようでしたら教えていただけると助かります。

社名　県名　・・・・・・
a 北海道
b 北海道
c 青森
d 青森
・
・
・
↓
シート名：北海道
社名　県名・・・・
a 北海道
b 北海道

回答No.2

mitarashi

オートフィルターで、極力マクロ自動記録でやってみました。元データはSheet1にあり、県名はB列とします。Sheet2に、重複しない県名リストを書き出してから処理します。元データ範囲は適宜変更してください。
XL2000のコードです。思いつきなのであまり検証してありませんので、あしからず。
Sub Macro1()
Dim i As Long
Dim prefname As String

'重複しない県名リストを作成
Sheets("Sheet1").Range("$B:$B").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet2").Range("A1"), Unique:=True

For i = 2 To Application.WorksheetFunction.CountA(Sheets("Sheet2").Range("$a:$a"))
prefname = Sheets("Sheet2").Cells(i, 1).Value
Sheets("Sheet1").Select
Range("A1:C5").Select '元データの範囲
'Range("A1").CurrentRegion.Select '目的の表が、ctrl+shift+:で選択できる場合
Selection.AutoFilter Field:=2, Criteria1:=prefname, Operator:=xlAnd
Selection.Copy
Sheets.Add
Range("A1").Select
ActiveSheet.Paste
ActiveSheet.Name = prefname
Next i
End Sub

お礼

自分なりにマクロ登録のみで作成できました。
ありがとうございました。

補足

回答ありがとうございました。
実行してみましたが、よく分からない結果に・・・
私のスキルでは修正できそうにありませんでした。

回答No.1

hige_082

この様な感じで？

Sub test()
Dim i, j
Dim ws As Worksheet
Set ws = ActiveSheet
For j = 2 To ws.Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To Worksheets.Count
If ws.Cells(j, 2).Value = Worksheets(i).Name Then
ws.Rows(j).Copy Worksheets(i).Cells(Rows.Count, 1).End(xlUp).Offset(1)
Exit For
ElseIf i = Worksheets.Count Then
Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = ws.Cells(j, 2).Value
ws.Rows(j).Copy ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1)
ws.Select
End If
Next i
Next j
End Sub

表の有るシートを表示してから実行してください
社名　県名・・・・<<これって何処まであるの？
質問が曖昧なので、この程度のマクロしか提示できませんよ
後はご自分で修正してくださいね

参考程度に

お礼

自分なりにマクロ登録のみで作成できました。
ありがとうございました。

補足

ありがとうございます。
取り敢えずそのまま実行してみましたが、
県の最後の一行が別シートに出力されてしまうようです。

残念ながら修正できるほどのスキルは持ち合わせていません。