| |
返答が遅くなり申し訳ありません。
うまくいきました。
本当にありがとうございました。
▼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のモジュールに入れて
>試してみて下さい。なお、既に同名のファイルが存在している場合は、
>それを削除してから新しいファイルを作ります。ご注意下さい。
|
|
発狂
- 07/3/11(日) 0:03 -
