ブックの分割をするとき

質問

お世話になります。

果物の出荷先を県別にまとめたシートがあります。それを県別に分割して、県ごとに新しいブックにコピーしたいと思っています。

Dim w As Worksheet
Dim n As Long
Dim r As Long
Dim s As String
Dim WSH As Variant
Dim myPath As String
Set w = ActiveSheet
n = Worksheets.Count
On Error GoTo errhandle
For r = 8 To w.Range("A65536").End(xlUp).Row
s = w.Cells(r, "B") & "_" & w.Cells(r, "C")
w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1)
Next r
On Error GoTo 0
Set WSH = CreateObject("Wscript.Shell")
myPath = WSH.specialfolders("Desktop") & "\"
For r = Worksheets.Count To n + 1 Step -1
Worksheets(Worksheets.Count).Copy
ActiveSheet.Columns.AutoFit
ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name
ActiveWorkbook.Close False
Application.DisplayAlerts = False
Worksheets(Worksheets.Count).Delete
Application.DisplayAlerts = True
Next r
w.Select
Exit Sub
errhandle:
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = s
w.Rows(1).Copy Range("A1")
Resume
End Sub

上記のマクロを実行した際に、解消したい点が2点あります。
1、項目(ヘッダー)としてコピーされる行が、現在1行目のみです。それを1～8行目にしたい。
2、ファイル名にセルを参照してコードと県名を繋げたものをつけているのですが、シート名もファイルと同じになってしまいます。シート名は元のファイルについているシート名を引き継ぎたいです(各県共通)

以上について、上記のコードのどの部分を変更すればよろしいでしょうか。
お分かりになられる方おられましたら、どうぞ教えてください。

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

回答No.1

ushi2015 · ベストアンサー

こんにちは
元のコードの動きが何か変な感じですが、そのままとして1、2部分だけ変更すると
　　Dim w As Worksheet
　　Dim n As Long
　　Dim r As Long
　　Dim s As String
　　Dim WSH As Variant
　　Dim myPath As String
　　Dim a As String
　　Dim b As String
　　Set w = ActiveSheet
　　a = w.Name
　　n = Worksheets.Count
　　On Error GoTo errhandle
　　For r = 8 To w.Range("A65536").End(xlUp).Row
　　　　s = w.Cells(r, "B") & "_" & w.Cells(r, "C")
　　　　w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1)
　　Next r
　　On Error GoTo 0
　　Set WSH = CreateObject("Wscript.Shell")
　　myPath = WSH.specialfolders("Desktop") & "\"
　　For r = Worksheets.Count To n + 1 Step -1
　　　　Worksheets(Worksheets.Count).Copy
　　　　ActiveSheet.Columns.AutoFit
　　　　b = ActiveSheet.Name
　　　　ActiveSheet.Name = a
　　　　ActiveWorkbook.SaveAs Filename:=myPath & b
　　　　ActiveWorkbook.Close False
　　　　Application.DisplayAlerts = False
　　　　Worksheets(Worksheets.Count).Delete
　　　　Application.DisplayAlerts = True
　　Next r
　　w.Select
　　Exit Sub
errhandle:
　　Worksheets.Add after:=Worksheets(Worksheets.Count)
　　ActiveSheet.Name = s
　　　　w.Rows("1:8").Copy Range("A1")
　　Resume
　　End Sub
こんな、感じですか？

お礼

ありがとうございました。
ちなみに、分割する際に元のシートの列幅も同じにしたいときは、どのようにすれば、よいでしょうか。

回答No.2

Prome_Lin

１．
「w.Rows(1).Copy Range("A1")」を
For r = 1 to 8
w.Rows(r).Copy Range("A" &r)
Next r

にする。

２．
ActiveSheet.Name = s

で、シートの名前を「s」にしています。

この行を削除してください。

お礼

ありがとうございました。
ちなみに、分割する際に元のシートの列幅も同じにしたいときは、どのようにすれば、よいでしょうか。