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