Excelの1シートを項目別に別シートへ分割

質問

左図のようなシートがあります。C列（部署番号）の左3桁をキーにデータとシートを分け、右図のようにシート名もその左3桁の名前にしたいと考えています。（部署番号）をキーにする場合は以下の通りとなると思うのですが
Sub test1()
Dim n As String
Dim c, L As Long
Dim ws1 As Worksheet

On Error GoTo ErrorHandler
Set ws1 = Sheets("Sheet1")

L = ws1.Range("C65536").End(xlUp).Row
For i = 2 To L
n = ws1.Range("C" & i) '部門名抽出
c = Sheets(n).Range("C65536").End(xlUp).Row '部門のシートの最終行位置
ws1.Rows(i).Copy Destination:=Sheets(n).Rows(c + 1)
Next i
Exit Sub
ErrorHandler: '部門のシートが無い時の処理
Worksheets.Add.Move after:=Worksheets(Worksheets.Count) '最後のシートの後へ追加
Worksheets(Worksheets.Count).Name = n '部門の名前をシートの名前にする
ws1.Rows(1).Copy Destination:=Sheets(n).Rows(1) '1行目の項目名をコピー
Resume
End Sub

（部署番号）の左3桁をキーにした時のコーディングがどうしても分かりません。このようなことが出来ますでしょうか。因みに元データとなる"sheet1"はそのまま残します。どうかご教授の程宜しくお願い致します。

回答No.1

real beatin（@realbeatin） · ベストアンサー

こんにちは。

添付画像のシート名「W10」は
部署番号「X100」と喰い違いがありますが、
さておき、
こんな感じで如何でしょうか？

　　　　n = 部門(ws1.Range("C" & i))
の部分は、関数を用いずとも、単に、
　　　　n = Left$(ws1.Range("C" & i).Text, 3)
としても同じ結果になりますが、
より明示的に「（部署番号）の左3桁をキーに」していることが
解り易くなり、後々の書換えが楽になるかという意図で
敢えて関数にしてあります。
.Textプロパティを使うのは、
文字列値であっても数値であっても、
表示された文字列を読むことで
"0"から始まる数値文字列（"0"から始まる表示形式）にも対応させる為です。

尚、ご提示のマクロへの修正という形でお応えするので、
仕様には変更を加えていません。
すでに出力が済んでいるデータについては
再度出力することになりますから、その点留意しておいて下さい。

何か不足があれば補足欄にでも書いてみて下さい。

' ' ///

Sub ReW9133479()
Dim ws1 As Worksheet
Dim n As String
Dim c As Long, L As Long, i As Long

　　Set ws1 = Sheets("Sheet1")

　　L = ws1.Range("C65536").End(xlUp).Row
　　For i = 2 To L
　　　　n = 部門(ws1.Range("C" & i))　'　★部門名抽出（関数にて左３桁抽出）
　　　　On Error GoTo ErrorHandler　'　★ エラートラップは限定的に！！
　　　　With Sheets(n)　'　★ With フレーズでシート参照を統一
　　　　　　On Error GoTo 0 '　★ エラートラップは限定的に！！
　　　　　　c = .Range("C65536").End(xlUp).Row '部門のシートの最終行位置
　　　　　　ws1.Rows(i).Copy Destination:=.Rows(c + 1)
　　　　End With　'　★
　　Next i
　　Exit Sub
ErrorHandler:　　 '部門のシートが無い時の処理
　　With Worksheets.Add(after:=Worksheets(Worksheets.Count)) '★最後のシートの後へ追加
　　　　.Name = n '★部門の名前をシートの名前にする
　　　　ws1.Rows(1).Copy Destination:=.Rows(1) '★1行目の項目名をコピー
　　End With　'　★ With フレーズでシート参照を統一
　　Debug.Print n　'　★新規追加シート名をイミディエイトウィンドウに表示
　　Resume
End Sub

Private Function 部門(r As Range) As String　'　★
　　部門 = Left$(r.Text, 3)　'　★
End Function　'　★

' ' ///

お礼

今晩は。ご丁寧にサポート頂き本当に有難うございました。
納得のいく結果出て一安心です。感謝いたします。