| |
▼hakemaru さん：
すみません。頭が固いので、詳細が分かりません。
代わりに、こちらがイメージした処理方法を紹介しますので、
参考にしてください。
あたらしいBookを挿入してその Sheet1 に 以下のようなデータを書き込んで
標準モジュールに、下のモジュールコードをコピーして、いったんこのBookを
適当なフォルダーに「名前を付けて保存」してください。
Sheet1 (元データ）
A列 B列 日付1 日付2 日付3 F列 G列 H列 ・・・S列
あ A 1/5 1/6 1/10 α GGG H2 S2
い B 1/5 1/6 1/10 β GGG H3 S3
う C 1/6 1/7 1/11 γ GGG H4 S4
え D 1/7 1/8 1/12 δ GGG H5 S5
お E 1/7 1/8 1/12 ε GGG H6 S6
か F 1/7 1/8 1/12 ζ GGG H7 S7
き G 1/10 1/11 1/15 η GGG H8 S8
く H 1/10 1/11 1/15 θ GGG H9 S9
け I 1/20 1/21 1/25 ι GGG H10 S10
こ J 1/20 1/21 1/25 κ GGG H11 S11
このコードを実行するとき、処理したい元データのあるシートを
アクティブにして、実行してください（今回は、対象データが、この
マクロのあるBook＝ThisWorkbook にありますが、元データは 必ずしも
マクロのあるBookである必要はありません）
'’───────────────────────── 標準モジュール
Option Explicit
Sub 表を日付別にBookに分ける()
Dim Path As String
Dim Sht1 As Worksheet
Dim Sht2 As Worksheet
Dim Rng1 As Range
'元データのあるBookの保存先
Path = ActiveWorkbook.Path & "\"
'元データのあるシートを変数にセット
Set Sht1 = ActiveWorkbook.Worksheets("Sheet1")
'元データ表範囲を変数数にセット
Set Rng1 = Sht1.Range("A1").CurrentRegion
'C列の日付データの種類を 同じシートにリストアップ
Rng1.Item(1, "AA").CurrentRegion.ClearContents 'リスト先クリア
Rng1.Columns("C").AdvancedFilter xlFilterCopy, _
CopyToRange:=Rng1(1, "AA"), Unique:=True
'日付け別にdataを抽出、新規BookにCopy
Dim newBook As Workbook
Dim Rng2 As Range
Dim c As Range
Dim i As Long
Set Rng2 = Rng1.Item(1, "AA").Resize(2) '抽出条件範囲
Set Rng1 = Intersect(Rng1, Rng1.Offset(, 1)) 'A列を除外
For i = 2 To Rng2.CurrentRegion.Count
'シートが1枚のBookを作成
Set newBook = Workbooks.Add(xlWBATWorksheet)
Set Sht2 = newBook.Worksheets(1)
'データ抽出転記
Rng1.AdvancedFilter xlFilterCopy, _
CriteriaRange:=Rng2, _
CopyToRange:=Sht2.Range("B1")
newBook.SaveAs Path & Format$(Rng2.Item(2), "mm-dd") & ".xls"
Set newBook = Nothing
'---次の抽出処理のために、日付リストを１つ上にシフトする
Rng2.Item(2).Delete Shift:=xlShiftUp
Set Rng2 = Rng2.Item(1).Resize(2)
Next
MsgBox "処理完了"
End Sub
A列に ABCを書き込む処理コードはご自分で考えてみてください。
|
|
kanabun
- 12/1/27(金) 11:12 -
