他ブックからデータ取得

質問

困っています、よろしくお願いします
現在画像のような月データ（例としてのため簡略化しています。実際はもっとデータ数は多いです）を大量に、いくつかのブックで保存しています。
これらをファイルごと、具体的にはAフォルダに12か月分あると考えてください

やりたい事としては、Aファイルにあるこの画像のデータのA列の日付を参照し、日付が変更した行から５行を取り出してその他の同日のデータは消去してを繰返して、Bファイルに新規保存していきたいです

この場合、2012/2/2のM列の値段が100から500までの５行を抽出し、他の2012/2/2の行を消去し詰める
その後2012/2/12の範囲のM列の値段が1500から1900までの５行を抽出し、他の2012/2/１2の行を消去し詰める
といった事を最終行まで繰返したいのです

この時、対象となる日付の5行以下ならそれら全てを参照、例えば５行を抽出し、他の2012/2/27のデータが3行しかないなら、それらをはじかず全てデータとしてとりこみたいです
また、できれば抽出する行数（この場合5行）を自由に変更できるようにもしたいです

日本語がおかしくてよく伝わらないとおもいますが、VBAとかプログラムとかこういうのが全くわからなくて困っています
ほんとうに、よろしくお願いいたします

回答No.1

eden3616

VBAで作成しています。
以下の手順(1)～(8)に沿って作業願います。

(1)新規ブックを作成
(2)Alt+F11でVBEを開く
(3)挿入→標準モジュールで標準モジュールを作成
(4)標準モジュールに最下のVBAコードを貼付
(5)コード内の「設定」項目を変更（以下の部分です）
　　'/////////////設定/////////////
　　'チェック対象列
　　tar_col = "A"
　　'重複削除基準値
　　del_row = "5"
　　'別名保存添付文字列
　　new_name = "New_"
　　'//////////////////////////////
(6)右上の×または、Alt+F11でVBEを閉じる
(7)Alt+F8　または　表示→マクロ　から「ファイル処理」を選び実行
(8)ファイルを開くダイアログが表示されるので対象のファイルを指定（複数可能）

(1)で作成し、コードを追加したブックを名前を付けて保存しておけば、
次回から上記手順の(7)(8)だけで利用できるようになります。

■VBAコード

Sub ファイル処理()
'型宣言
Dim fpath As Variant, dpath As String, tbook As Workbook
Dim i As Long, j As Long, cnt As Long
Dim bkRng As String, myRng As Range
Dim tar_col As String, del_row As Long, new_name As String
Dim fn As String, exfn As String

'/////////////設定/////////////
'チェック対象列
tar_col = "A"
'重複削除基準値
del_row = "5"
'別名保存添付文字列
new_name = "New_"
'//////////////////////////////

'ファイル指定
fpath = Application.GetOpenFilename("全てのファイル (*.*), *.*", MultiSelect:=True)
If IsArray(fpath) = False Then Exit Sub
'ディレクトリパス取得
dpath = Replace(fpath(1), Dir(fpath(1)), "")
'ファイル処理
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To UBound(fpath)
　　'初期化
　　bkRng = ""
　　Set myRng = Nothing
　　'ファイル名・拡張子の取得
　　fn = Dir(fpath(i))
　　fn = Left(fn, InStrRev(fn, ".") - 1)
　　exfn = Right(Dir(fpath(i)), Len(Dir(fpath(i))) - Len(fn))
　　'ブック開く
　　Set tbook = Workbooks.Open(fpath(i))
　　With tbook.ActiveSheet
　　　　'行数ループ
　　　　For j = 1 To .Range(tar_col & Rows.Count).End(xlUp).Row
　　　　　　'対象セル判定・カウントアップ
　　　　　　If bkRng <> .Range(tar_col & j).Text Then
　　　　　　　　bkRng = .Range(tar_col & j).Text
　　　　　　　　cnt = 1
　　　　　　Else
　　　　　　　　cnt = cnt + 1
　　　　　　End If
　　　　　　'カウント値が指定行数より多ければ対象として設定
　　　　　　If cnt > del_row Then
　　　　　　　　If myRng Is Nothing Then
　　　　　　　　　　Set myRng = .Rows(j)
　　　　　　　　Else
　　　　　　　　　　Set myRng = Union(myRng, .Rows(j))
　　　　　　　　End If
　　　　　　End If
　　　　Next j
　　　　'行削除
　　　　If Not myRng Is Nothing Then myRng.Delete
　　End With
　　'別名保存
　　If Dir(dpath & new_name & Dir(fpath(i))) = "" Then
　　　　tbook.SaveAs Filename:=dpath & new_name & fn & exfn
　　Else
　　　　'添え字追加保存
　　　　j = 1
　　　　Do Until Dir(dpath & new_name & fn & "(" & j & ")" & exfn) = ""
　　　　　　j = j + 1
　　　　Loop
　　　　tbook.SaveAs Filename:=dpath & new_name & fn & "(" & j & ")" & exfn
　　End If
　　'ブック終了
　　tbook.Close
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox i - 1 & "件終了しました"
End Sub