Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
6055 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【47350】ブックを作成し、元データから分割した内容を保存したい。 発狂 07/3/8(木) 20:05 質問[未読]
【47353】Re:ブックを作成し、元データから分割した... Kein 07/3/8(木) 20:56 回答[未読]
【47454】Re:ブックを作成し、元データから分割した... 発狂 07/3/11(日) 0:03 お礼[未読]
【47350】ブックを作成し、元データから分割した内...
質問  発狂  - 07/3/8(木) 20:05 -
引用なし
パスワード
   初めまして。
どうにも処理の方法がわからず困ってます。教えて下さい。

（例）
■Book名：全データ.xls
　ｼｰﾄ名 ：担当

A1　B1　　　　　C1
-------------------------------
01　山田太郎　　10
01　山田太郎　　20
02　佐藤春子　　20
03　高木次郎　　10
03　高木次郎　　30

というデータがあったとします。

＜処理したい内容＞
1.B1の名前をブック名とする。
　山田太郎.xls
　佐藤春子.xls
　高木次郎.xls

2.ｼｰﾄ名は元のｼｰﾄ名をそのまま継承
　⇒上記の場合だと「担当」

3.データは山田太郎.xlsであれば、全データ.xlsの山田太郎のデータのみコピーして
　貼り付け。佐藤春子.xlsであれば、全データ.xlsの佐藤春子のデータのみコピーして
貼り付け。

4.保存

といったような事を行いたいと思ってます。
どのようにすれば最善の方法なのか、どなたか教えて下さい。

お願いします。
【47353】Re:ブックを作成し、元データから分割し...
回答  Kein  - 07/3/8(木) 20:56 -
引用なし
パスワード
   通常エクセルブックを開くフォルダーへ保存するとして・・

Sub Mk_MyBooks()
　 Dim MyR As Range, C As Range
　 Dim Fol As String, Fnm As String
　
　 With Application
　　　Fol = .DefaultFilePath & "\"
　　　.ScreenUpdating = False
　 End With
　 With Worksheets("担当")
　　　.Rows(1).Insert xlShiftDown
　　　.Range("A1:C1").Value = Array("Dt1", "Dt2", "Dt3")
　　　With .Range("A1").CurrentRegion
　　　　 .Sort Key1:=.Columns(1), Order1:=xlAscending, _
　　　　 Header:=xlYes, Orientation:=xlSortColumns
　　　　 .Subtotal 1, xlSum, Array(3)
　　　End With
　　　Set MyR = .Range("B2", .Range("B65536").End(xlUp)) _
　　　.SpecialCells(2)
　 End With
　 For Each C In MyR.Areas
　　　Fnm = Fol & C.Cells(1).Value & ".xls"
　　　If Dir(Fnm) <> "" Then Kill Fnm
　　　Workbooks.Add xlWBATWorksheet
　　　With ActiveWorkbook
　　　　 C.EntireRow.Copy
　　　　 With .Worksheets(1)
　　　　　　.Range("A1").PasteSpecial xlPasteValues
　　　　　　.Range("A1").Select
　　　　　　.Name = "担当"
　　　　 End With
　　　　 .Close True, Fnm
　　　End With
　　　Application.CutCopyMode = False
　 Next
　 With Worksheets("担当")
　　　.Cells.RemoveSubtotal
　　　.Rows(1).Delete xlShiftUp
　 End With
　 Application.ScreenUpdating = True: Set MyR = Nothing
　 MsgBox "個人別データで新規ブックを作成しました", 64
End Sub

というコードで出来ると思います。全データ.xlsのモジュールに入れて
試してみて下さい。なお、既に同名のファイルが存在している場合は、
それを削除してから新しいファイルを作ります。ご注意下さい。
【47454】Re:ブックを作成し、元データから分割し...
お礼  発狂  - 07/3/11(日) 0:03 -
引用なし
パスワード
   返答が遅くなり申し訳ありません。
うまくいきました。
本当にありがとうございました。


▼Kein さん：
>通常エクセルブックを開くフォルダーへ保存するとして・・
>
>Sub Mk_MyBooks()
>　 Dim MyR As Range, C As Range
>　 Dim Fol As String, Fnm As String
>　
>　 With Application
>　　　Fol = .DefaultFilePath & "\"
>　　　.ScreenUpdating = False
>　 End With
>　 With Worksheets("担当")
>　　　.Rows(1).Insert xlShiftDown
>　　　.Range("A1:C1").Value = Array("Dt1", "Dt2", "Dt3")
>　　　With .Range("A1").CurrentRegion
>　　　　 .Sort Key1:=.Columns(1), Order1:=xlAscending, _
>　　　　 Header:=xlYes, Orientation:=xlSortColumns
>　　　　 .Subtotal 1, xlSum, Array(3)
>　　　End With
>　　　Set MyR = .Range("B2", .Range("B65536").End(xlUp)) _
>　　　.SpecialCells(2)
>　 End With
>　 For Each C In MyR.Areas
>　　　Fnm = Fol & C.Cells(1).Value & ".xls"
>　　　If Dir(Fnm) <> "" Then Kill Fnm
>　　　Workbooks.Add xlWBATWorksheet
>　　　With ActiveWorkbook
>　　　　 C.EntireRow.Copy
>　　　　 With .Worksheets(1)
>　　　　　　.Range("A1").PasteSpecial xlPasteValues
>　　　　　　.Range("A1").Select
>　　　　　　.Name = "担当"
>　　　　 End With
>　　　　 .Close True, Fnm
>　　　End With
>　　　Application.CutCopyMode = False
>　 Next
>　 With Worksheets("担当")
>　　　.Cells.RemoveSubtotal
>　　　.Rows(1).Delete xlShiftUp
>　 End With
>　 Application.ScreenUpdating = True: Set MyR = Nothing
>　 MsgBox "個人別データで新規ブックを作成しました", 64
>End Sub
>
>というコードで出来ると思います。全データ.xlsのモジュールに入れて
>試してみて下さい。なお、既に同名のファイルが存在している場合は、
>それを削除してから新しいファイルを作ります。ご注意下さい。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
6055 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free