他のシートのデータを飛ばしたい（マクロor条件付き書式などで）

他データの発注書を別の発注書に該当内容をデータで飛ばしたく、
マクロや条件付き書式に疎いため、スキルのある方に教えていただきたいです。
飛ばす内容は下記のような内容です。

＜飛ばす元データ＞
日付　　食事内容　　　商品名　　　　規格　単位　1人前　単位
8/1　　　朝食　　　　オムレツ　　　5　　　個　　1　個
8/1　　　朝食　　　　サラダ　　　　240　　ｇ　　30　　ｇ
8/1　　　昼食　　　　親子丼　　　　300　　ｇ　　100　 ｇ
8/1　　　昼食　　　　里芋煮　　　　400　　ｇ　　40　　ｇ
8/1　　　夕食　　　　カレー　　　　300　　ｇ　　100　 ｇ
8/1　　　夕食　　　　炒め物　　　　240　　ｇ　　40　　ｇ
8/2　　　朝食　　　　がんも煮　　　500　　ｇ　　80　　ｇ
8/2　　　朝食　　　　いんげん和え　240　　ｇ　　30　　ｇ
8/2　　　昼食　　　　豚生姜焼き　　500　　ｇ　　100　 ｇ
8/2　　　夕食　　　　まぐろ丼　　　300　　ｇ　　100　 ｇ

＜飛ばす先データ＞
添付の画像内容になります。
その日により行数が変わるため、どうとばしていいのかわからず
ご相談させていただきました。
何卒お願いいたします。

No.3 回答者： ママチャリ 回答日時： 2018/08/04 11:19

飛ばしてはいないのですが、最近、こういう編集がマイブームです。

Sub hensyu()
Dim r As Long
Dim dt As Range: Set dt = Range("A2")
Dim et As Range: Set et = Range("B2")
Application.DisplayAlerts = False
For r = 3 To Cells(Rows.Count, "A").End(xlUp).Row + 1
If dt(1).Value = Cells(r, "A").Value Then
Set dt = Union(dt, Cells(r, "A"))
Else
dt.Merge
Set dt = Cells(r, "A")
et.Merge
Set et = Cells(r, "B")
End If
If et(1).Value = Cells(r, "B").Value Then
Set et = Union(et, Cells(r, "B"))
Else
et.Merge
Set et = Cells(r, "B")
End If
Next r
Range(Range("A1"), Range("A1").SpecialCells(xlLastCell)).Borders.Weight = xlThin
End Sub

この回答へのお礼

ありがとうございます！！
返信が遅くなり申し訳ありません。
早速使用させていただきます！！

お礼日時：2018/08/15 12:49

No.2 回答者： tom04 回答日時： 2018/08/03 23:01

NO.1です。

エラーが出たというコトですが、
お使いのExcelのバージョンは何になるのでしょうか？
もしかすると
＞Set c = wS.Range("A:A").Find(what:=DateValue(.Cells(i, "A")), LookIn:=xlFormulas, lookat:=xlWhole)

の部分で「日付」セルを見つけ出すことができていないのかもしれません。
上記コードはおそらくExcel2010以降で使えるのではないかと思います。
No.1のコードの上記1行を

＞Set c = wS.Range("A:A").Find(what:=Format(.Cells(i,"A"), "m月d日"), LookIn:=xlValues, lookat:=xlWhole)
としてみてください。

※　m月d日　の部分は実際のSheet1のセルの表示形式に合わせてください。m(_ _)m

この回答へのお礼

ありがとうございます！！
いただいた内容でエラー解除できました(^^♪
返信が遅くなり申し訳ありません。

お礼日時：2018/08/15 12:50

No.1 回答者： tom04 回答日時： 2018/08/02 22:03

こんばんは！

VBAでの一例です。
Sheet1・Sheet2は↓の画像のような配置になっているという前提です。
標準モジュールにしてください。

Sub Sample1()
　Dim i As Long, k As Long, lastRow As Long
　Dim c As Range, wS As Worksheet
　　Set wS = Worksheets("Sheet2")
　　　lastRow = wS.Cells(Rows.Count, "D").End(xlUp).Row
　　　　If lastRow > 1 Then
　　　　　Range(wS.Cells(2, "D"), wS.Cells(lastRow, "G")).ClearContents
　　　　End If
　　　With Worksheets("Sheet1")
　　　　For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　Set c = wS.Range("A:A").Find(what:=DateValue(.Cells(i, "A")), LookIn:=xlFormulas, lookat:=xlWhole)
　　　　　　For k = c.Row To wS.Cells(Rows.Count, "B").End(xlUp).Row
　　　　　　　If wS.Cells(k, "B") = Left(.Cells(i, "B"), 1) Then Exit For
　　　　　　Next k
　　　　　　If wS.Cells(k, "D") <> "" Then
　　　　　　　Do Until wS.Cells(k, "D") = ""
　　　　　　　　k = k + 1
　　　　　　　Loop
　　　　　　End If
　　　　　　　wS.Cells(k, "D") = .Cells(i, "C")
　　　　　　　wS.Cells(k, "E") = .Cells(i, "D") & .Cells(i, "E")
　　　　　　　wS.Cells(k, "F") = .Cells(i, "F") & .Cells(i, "G")
　　　　Next i
　　　End With
End Sub

※　Sheet2の「1日」の行数はすべて画像通りの行数で
すでに配置済みだとします。

※　Sheet2のD～G列だけの操作にしています。m(_ _)m

この回答へのお礼

tom04様

早々にご検討いただき有難うございます。
動かしてみたところ、エラー91が出てしまいました。
オブジェクト変数または With ブロック変数が設定されていません。
となっています。。。
もしお時間ありましたら、教えていただけますと幸いです。

お礼日時：2018/08/03 10:49