Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

75036 / 76732

←次へ　｜　前へ→


	【6145】Re:部門ごとにシートを分けたいのですが

パピー（ＰＡＰＩー） - 03/6/17(火) 16:24 -


	引用なし

	パスワード

▼りんさん: こんにちは｡
サンプルを作ってみました｡
分ける前のシート名はSheet1としました｡
後は､自動的に部門名のシートを追加して振り分けます｡
1 行目には項目名が入っているものとし､データは2行目からです｡
参考になれば幸いです｡
試してみて下さい｡

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

　　On Error GoTo ErrorHandler
　　Set ws1 = Sheets("Sheet1")
　　
　　L = ws1.Range("A65536").End(xlUp).Row
　　For i = 2 To L
　　　n = ws1.Range("D" & i)　　　　　　　　　　　　'部門名抽出
　　　c = Sheets(n).Range("A65536").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

1 hits

▼

【6139】部門ごとにシートを分けたいのですが りん 03/6/17(火) 14:59