部署ごとに分割し、ブックで保存するコード

質問

部署ごとに分割し、ブックで保存するコードです。
A1、1列目から分割していますが、B2、4列目から分割する方法を教えてください。
A65536をB65536に変えたりなどしていましたが、エラーが出ます。
よろしくお願いします。

Sub macro1()
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

Application.ScreenUpdating = False

On Error GoTo errhandle
For r = 2 To w.Range("A65536").End(xlUp).Row
s = w.Cells(r, "A")
w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1)
Next r
On Error GoTo 0

Set WSH = CreateObject("Wscript.Shell")
myPath = ThisWorkbook.Path & "\"

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
Application.ScreenUpdating = True
End Sub

回答No.9

kkkkkm · ベストアンサー

> w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1)

w.Rows(r).Copy Worksheets(s).Range("B65536").End(xlUp).Offset(1, -1)

にしてみてください

お礼

色々とありがとうございます。
おかげさまでうまくいきました。

回答No.8

SI299792

キャプチャを見てなかったので、４行目からデータが始まっていると思いました。
５行目からならこうです。'*が変更点です。
気になったのは、担当組織が順番に並んでいないみたいですが、これでいいですか。
（並んでいなくても、実行前にソートすれば使えますが）

Option Explicit
'
Sub Macro1()
　　Dim I As Worksheet
　　Dim RSta As Long
　　Dim REnd As Long
　　Dim What As String
　　Dim Count As Integer
'
　　Set I = ThisWorkbook.ActiveSheet
　　Workbooks.Add
　　I.[1:4].Copy [A1] '*
　　RSta = 5 '*
　　REnd = I.Cells(Rows.Count, "B").End(xlUp).Row
'
　　While RSta <= REnd
　　　　What = I.Cells(RSta, "B")
　　　　Count = WorksheetFunction.CountIf(I.[B:B], What)
　　　　Rows(5 & ":" & Rows.Count).ClearContents '*
　　　　I.Rows(RSta).Resize(Count).Copy [A5] '*
　　　　Application.DisplayAlerts = False
　　　　ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & What
　　　　Application.DisplayAlerts = True
　　　　RSta = RSta + Count
　　Wend
　　ActiveWorkbook.Close
End Sub

何で前の回答が消せないんだ！

お礼

ありがとうございます。
うまくできました。ベストアンサーにしてあげたいのですが、kkkkkm様の方が色々とアドバイスをもらいましたし、解決できましたので、ベストアンサーはkkkkkm様にします。すみません。

回答No.7

kkkkkm

> この名前は既に使用されています。別の名前を入力してください。
> とエラーメッセージが出ます。

いままで出てなかったのでしたら、2か所変更したものを一か所にしてどちらを変更したら出るのか確認してください。
また
w.Rows(2).Copy Range("A2")
w.Rows(3).Copy Range("A3")
w.Rows(4).Copy Range("A4")

上記を一個ずつ外してエラーが出るかどうか見てください。

補足

w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1)
に戻したら保存できましたけど、４行目の項目の方は変わりませんでした…

回答No.6

kkkkkm

w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1)
こちらもB列を指定したほうがいいと思いますので
w.Rows(r).Copy Worksheets(s).Range("B65536").End(xlUp).Offset(1)

補足

この名前は既に使用されています。別の名前を入力してください。
とエラーメッセージが出ます。
「ActiveSheet.Name = s」が原因のようです。

Sub macro1()
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

Application.ScreenUpdating = False

On Error GoTo errhandle
For r = 5 To w.Range("B65536").End(xlUp).Row
s = w.Cells(r, "B")
w.Rows(r).Copy Worksheets(s).Range("B65536").End(xlUp).Offset(1)
Next r
On Error GoTo 0

Set WSH = CreateObject("Wscript.Shell")
myPath = ActiveWorkbook.Path & "\"

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")
w.Rows(2).Copy Range("A2")
w.Rows(3).Copy Range("A3")
w.Rows(4).Copy Range("A4")
Resume
Application.ScreenUpdating = True
End Sub

回答No.5

kkkkkm

> 2行目から４行目が削除してしまっています。

そこも各シートに必要だということでしたら

errhandle:
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = s
w.Rows(1).Copy Range("A1")
Resume
のところを
errhandle:
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = s
w.Rows(1).Copy Range("A1")
w.Rows(2).Copy Range("A2")
w.Rows(3).Copy Range("A3")
w.Rows(4).Copy Range("A4")
Resume
として
For r = 4 To w.Range("B65536").End(xlUp).Row
を
For r = 5 To w.Range("B65536").End(xlUp).Row
にすればいかがでしょう。

回答No.4

kkkkkm

A4が空白だからだと思います。
A列のデータでなくB列のデータがシート名でしたら
s = w.Cells(r, "A")
を
s = w.Cells(r, "B")
に
ただそれで正しい動作かどうかは分かりません。

補足

動作はしますが、４行目の項目は変わらず消えてしまっています。
2行目から４行目が削除してしまっています。
https://drive.google.com/file/d/14CpejGO4_yww6p_RM37IzgXptZMtwf1R/view?usp=sharing

回答No.3

kkkkkm

> ４行目も残しながら分割したいのです。

rが行ですから

For r = 4 To w.Range("B65536").End(xlUp).Row

でいいのではないでしょうか。

補足

結果
実行時エラー1004
アプリケーション定義またはオブジェクト定義のエラーです。
とエラーメッセージが出ます。

回答No.2

SI299792

プログラムは複雑すぎて、見る気になりませんでした。
もし、シートが１つでＢ列のデータが部署順に並んでるなら、これでできます。
部署順に並んでいないなら補足に書いて下さい。

Sub Macro1()
　　Dim I As Worksheet
　　Dim RSta As Long
　　Dim REnd As Long
　　Dim What As String
　　Dim Count As Integer
'
　　Set I = ThisWorkbook.ActiveSheet
　　Workbooks.Add
　　RSta = 4
　　I.[1:3].Copy [A1]
　　REnd = I.Cells(Rows.Count, "B").End(xlUp).Row
'
　　While RSta <= REnd
　　　　What = I.Cells(RSta, "B")
　　　　Count = WorksheetFunction.CountIf(I.[B:B], What)
　　　　Rows(4 & ":" & Rows.Count).ClearContents
　　　　I.Rows(RSta).Resize(Count).Copy [A4]
　　　　Application.DisplayAlerts = False
　　　　ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & What
　　　　Application.DisplayAlerts = True
　　　　RSta = RSta + Count
　　Wend
　　ActiveWorkbook.Close
End Sub

お礼

コメントありがとうございます。
シンプルなコードで、うまくできました。

回答No.1

kkkkkm

> A1、1列目から分割していますが、B2、4列目から分割する方法を教えてください。

現状がA1+1行目でB2+4行目に変更でしたら
For r = 2 To w.Range("A65536").End(xlUp).Row
を
For r = 6 To w.Range("B65536").End(xlUp).Row

よくわかりませんがもしかしたらセルに値がない時にエラーにっているのではないでしょうか。

お礼

いつもありがとうございます。
B65536に変えるのは一つだけでしたか。もう一つのA65536もB65536に変えたのがいけなかったんですね。
ですが、4行目が項目で、消えてしまっています。
１行目がタイトルで、2～3行目は空白、４行目が項目です。
４行目も残しながら分割したいのです。
イメージ
https://drive.google.com/file/d/14OVcV4mE6A0uYoRLe5gJ2K-Xz7Zb1u9l/view?usp=sharing