Excel VBA質問箱 IV

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

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


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

34589 / 76734

←次へ　｜　前へ→


	【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のモジュールに入れて
試してみて下さい。なお、既に同名のファイルが存在している場合は、
それを削除してから新しいファイルを作ります。ご注意下さい。

1 hits

▼

【47350】ブックを作成し、元データから分割した内容を保存したい。 発狂 07/3/8(木) 20:05