みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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"はそのまま残します。どうかご教授の程宜しくお願い致します。

投稿日時 - 2016-02-24 22:38:45

QNo.9133479

困ってます

質問者が選んだベストアンサー

こんにちは。

添付画像のシート名「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)) ' ★部門名抽出(関数にて左3桁抽出)
    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 ' ★

' ' ///

投稿日時 - 2016-02-25 07:07:34

お礼

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

投稿日時 - 2016-02-25 23:52:42

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(1)

あなたにオススメの質問