Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
13279 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【6139】部門ごとにシートを分けたいのですが りん 03/6/17(火) 14:59 質問
【6145】Re:部門ごとにシートを分けたいのですが パピー（ＰＡＰＩー） 03/6/17(火) 16:24 回答
【6148】Re:部門ごとにシートを分けたいのですが Jaka 03/6/17(火) 17:29 回答
【6184】Re:部門ごとにシートを分けたいのですが りん 03/6/18(水) 13:46 質問
【6186】Re:部門ごとにシートを分けたいのですが Jaka 03/6/18(水) 14:24 回答
【6187】Re:部門ごとにシートを分けたいのですが りん 03/6/18(水) 14:37 お礼
【6188】Re:部門ごとにシートを分けたいのですが パピー（ＰＡＰＩー） 03/6/18(水) 15:07 発言
【6139】部門ごとにシートを分けたいのですが
質問  りん  - 03/6/17(火) 14:59 -
引用なし
パスワード
   こんにちは。ＶＢＡ初心者です。
下記のような表があるのですが、
これを部門ごとに３つのシートに
わけて、シートに部門の名前を
付けたいのですが、どうすれば
いいかわかりません。教えていただけ
ないでしょうか？

--------------------------------------
　　A　　　B　　　 C　　　　D　 　　E
　　No.　　ｺｰﾄﾞ　会社名　　部門　　金額
1 00201 　201　　ｱﾔﾏ　　　CJ20　　3,000
2 00202　 202　　ｾｲｺｳ　　 CJ20　 5,000　
3 00501　 501　　ｳｴｽﾀﾝ　　CJ20　 2,000
4 00503　 503　　ｳｴﾀﾞ　　 CJ50　 1,000
5 00505　 505　　ﾏﾂｴ　　　CJ50　 3,000
6 00602　 602　　ﾏﾂﾀﾞ　　 CJ70　 2,000
7 00603　 603　　ｴｲｺｳ　　 CK70　 5,000
　↓
下につづく　

----------------------------------------
参考1.部門名はCJ20、CJ50、CJ70の３つだけです。
　　
　　2.このデータは部門ごとに並べ替えられていますので

　　3.データの個数は不特定です。

この説明でわかりますでしょうか？？
【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
【6148】Re:部門ごとにシートを分けたいのですが
回答  Jaka  - 03/6/17(火) 17:29 -
引用なし
パスワード
   こんにちは。
別解です。
データシートをアクティブとした状態で、かつデータシートの１行目は項目名として。

Sub bobo()
　　Dim roe As Long, coe As Integer, DtSh As Worksheet
　　Set DtSh = ActiveSheet
　　roe = DtSh.Cells(Rows.Count, "D").End(xlUp).Row
　　coe = DtSh.Cells(1, Columns.Count).End(xlToLeft).Column
　　bumo = Array("CJ20", "CJ50", "CJ70")
　　Application.ScreenUpdating = False
　　For i = 0 To UBound(bumo)
　　　　DtSh.Range("D1:D" & roe).AutoFilter Field:=1, Criteria1:=bumo(i)
　　　　Worksheets.Add after:=Worksheets(Worksheets.Count)
　　　　ActiveSheet.Name = bumo(i)
　　　　DtSh.Rows(1).Copy Sheets(bumo(i)).Range("A1")
　　　　DtSh.Range("A2", DtSh.Cells(roe, coe)).SpecialCells(xlCellTypeVisible).Copy Sheets(bumo(i)).Range("A2")
　　　　DtSh.Range("A" & roe).AutoFilter
　　Next
　　Application.ScreenUpdating = True
End Sub
【6184】Re:部門ごとにシートを分けたいのですが
質問  りん  - 03/6/18(水) 13:46 -
引用なし
パスワード
   こんにちは。パピーさん、Jakaさん、
回答ありがとうございます。
パピーさんのやり方でやってみたのですが、
シートの名前をつけるところで、どうしても
エラーになってしまい、できなかったので、
（私のやり方が悪かっただけだと思いますが）
Jakaさんの方法でやってみました。
こちらはお手本通りにやるとちゃんと
できました。

そこでもう一つ質問なのですが、
実際に作る資料では、新たに作るシートに
"CJ20仕入2."、"CJ50仕入2."、"CJ70仕入2.”
というように、部門名に”仕入2.”という
文字を入れた名前を付けたいのですが、
これにはJakaさんの式のどこを変えたら
よいのでしょうか？
教えて下さい。
よろしくお願いします！
【6186】Re:部門ごとにシートを分けたいのですが
回答  Jaka  - 03/6/18(水) 14:24 -
引用なし
パスワード
   ▼りん さん：
>そこでもう一つ質問なのですが、
>実際に作る資料では、新たに作るシートに
>"CJ20仕入2."、"CJ50仕入2."、"CJ70仕入2.”
>というように、部門名に”仕入2.”という
>文字を入れた名前を付けたいのですが、
>これにはJakaさんの式のどこを変えたら
>よいのでしょうか？
>教えて下さい。
>よろしくお願いします！

シート名にですか？
シート名なら

ActiveSheet.Name = bumo(i) & "仕入2."
【6187】Re:部門ごとにシートを分けたいのですが
お礼  りん  - 03/6/18(水) 14:37 -
引用なし
パスワード
   こんにちは。

>シート名にですか？
>シート名なら
>
>ActiveSheet.Name = bumo(i) & "仕入2."

これでできました！
どうもありがとうございました！！
【6188】Re:部門ごとにシートを分けたいのですが
発言  パピー（ＰＡＰＩー）  - 03/6/18(水) 15:07 -
引用なし
パスワード
   ▼りん さん：こんにちは。
>こんにちは。パピーさん、Jakaさん、
>回答ありがとうございます。
>パピーさんのやり方でやってみたのですが、
>シートの名前をつけるところで、どうしても
>エラーになってしまい、できなかったので、

そうですか、私のテストでは問題なく動いたのですがね。
どの様なエラーでしょうか？

しかし、Jakaさんの方式でうまく動いたようですから、
良しとしましょうか？
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
13279 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free