エクセルマクロ、特定の日付を別シート、かつ限られた範囲への抽出方法

c:\元データ　の　元データ　シートの、A列には日付、B列に情報1、C列に情報２が入力積みです。

元データ
A B C
2016/1/1 情報11 情報21
2016/1/1 情報12 情報22
2016/1/1 情報13 情報23
2016/1/2 情報14 情報24
2016/1/3 情報15 情報25
2016/1/3 情報16 情報26
2016/1/3 情報17 情報27
2016/1/3 情報18 情報28
2016/1/4 情報19 情報29
つづく…(1月31日まで1ヶ月分あると思ってください。)


これを、同じブックの別シート、かつ、レイアウトが決められた範囲内に抽出したいです。

レイアウトが決められたシートには日付が記入されていて、隣の列に10行分だけがその日付分として割り当てられています。

別シート
A B C
2016/1/1(*) 空白11 空白21
空白02 空白12 空白22
空白03 空白13 空白23
空白04 空白14 空白24
空白05 空白15 空白25
空白06 空白16 空白26
空白07 空白17 空白27
空白08 空白18 空白28
空白09 空白19 空白29
空白A0 空白B0 空白C0
2016/1/2 空白B1 空白C1
空白A2 空白B2 空白C2
空白A3 空白B3 空白C3
空白A4 空白B4 空白C4

上記の空白11と21から埋めていって、この場合だと情報11，12，13，21,22,23(B,C列)を空白23まで埋めます。B,C列の一桁が4~0と、A列の空白02~A0は空白のままとします。
2016/1/1の処理が終わったら、2016/1/2から再度、情報14，24(B,C列)だけを入力する、というものです。

オートフィルターを使うと、2月に入ったらまた別のマクロを作らなければならないため、上記の別シートの日付(*)を使って照合させて、元データシートから抽出させたいです。

適切なマクロを教えてください。

よろしくお願いします。

質問者からの補足コメント

• 私の頭の中の作業の流れとしては、
  
  １．別シートのA列の日付を若い順に参照する。
  ２．元データシートのA列でvlookup的に該当する行を判別する。
  　　vlookupだと1項目1行しか返せないと認識しているため、今回の場合には不適切と思っています。
  ３．10行を超える場合は別シートには記入せず、処理を飛ばす。
  ４．別シートのA列の日付に合致する数行(B,C列のみ)を別シートの所定の空欄にコピペする
  ５．別シートのA列の日付で、次に若い日付のデータを参照する。
  ６．以下、２．と同じ。
  
  です。VBAで無理そうであれば、適切な処理方法をご指導いただければ助かります。
  関数でもOKです。

    補足日時：2016/05/06 16:58

No.1 回答者： soixante 回答日時： 2016/05/07 19:54

ご意向にそぐっているか分かりませんが、以下のようにやってみました。

＜主な流れ＞
・シートは３つ用意してください。moto,kako,betsu
元シート（moto）、加工（kako）、別シート（betsu)

・元シートのデータ、日付ごとに全情報を一行に並べる（加工シートに）
・加工シートをもとに別シートに転記する。その場合、6つまでのデータは所定の箇所に記入し、
　それ以降（7番目以降）のデータはスルー

’------------------------------------------------------------------

'変数宣言
Dim WsM As Worksheet, WsK As Worksheet, WsB As Worksheet
Dim WSF As Object
Set WsM = Worksheets("moto")
Set WsK = Worksheets("kako")
Set WsB = Worksheets("betsu")
Set WSF = Application.WorksheetFunction

Dim Dic As Variant, Hiduke As Date
Dim myKeys As Variant
Dim r As Long, c As Long
Dim TgtRow As Long, LstCol As Long
Dim Joho As String

Set Dic = CreateObject("Scripting.Dictionary")

' 加工シートに日付の非重複リストを作成
WsK.Cells.ClearContents
r = 1
Do While WsM.Cells(r, 1).Value <> ""
　　Hiduke = WsM.Cells(r, 1).Value
　　If Not Dic.exists(Hiduke) Then
　　　Dic.Add Hiduke, Hiduke
　　End If
　　r = r + 1
Loop
myKeys = Dic.keys

For r = 0 To Dic.Count - 1
　　WsK.Cells(r + 1, 1).Value = myKeys(r)
Next r

'加工シートに日付ごとに全情報を一行にまとめて転記
r = 1
Do While WsM.Cells(r, 1).Value <> ""
　　For c = 2 To 3
　　　TgtRow = WSF.Match(WsM.Cells(r, 1), WsK.Columns(1), 0)
　　　LstCol = WsK.Cells(TgtRow, Columns.Count).End(xlToLeft).Column + 1
　　　WsK.Cells(TgtRow, LstCol).Value = WsM.Cells(r, c).Value
　　Next c
　　r = r + 1
Loop

'加工シートのデータを別シートに転記
r = 1
Do While WsK.Cells(r, 1).Value <> ""
　　Hiduke = WsK.Cells(r, 1)
　　TgtRow = WSF.Match(Hiduke, WsB.Columns(1), 0)
　　LstCol = WsK.Cells(r, Columns.Count).End(xlToLeft).Column
　　For c = 2 To LstCol
　　　　Joho = WsK.Cells(r, c).Value
　　　　Select Case c
　　　　　　Case 2
　　　　　　　 WsB.Cells(TgtRow, 2).Value = Joho
　　　　　　Case 3
　　　　　　　WsB.Cells(TgtRow, 3).Value = Joho
　　　　　　Case 4
　　　　　　　 WsB.Cells(TgtRow + 1, 2).Value = Joho
　　　　　　Case 5
　　　　　　　WsB.Cells(TgtRow + 1, 3).Value = Joho
　　　　　　Case 6
　　　　　　　WsB.Cells(TgtRow + 2, 2).Value = Joho
　　　　　　Case 7
　　　　　　　 WsB.Cells(TgtRow + 2, 3).Value = Joho
　　　　　　Case Is >= 8
　　　　End Select
　　Next c
　　r = r + 1
Loop

'変数開放
Set Dic = Nothing
Set WSF = Nothing
Set WsM = Nothing
Set WsK = Nothing
Set WsB = Nothing

End Sub