セル間でデータの更新、追加をする

①I列11行目以降には出荷予定の果物の名前が入っています。
　F列11行目以降にはその予定納期

②L列11行目以降には納期確定の果物の名前が入っています。
　M列11行目以降にはその確定納期

やりたいことはVBAで②のデータを①に更新することです。
（同じ果物名の予定納期を確定納期に変更する）
②に①に存在しない新たなデータがあった場合、①I列11行目以降、F列11行目以降の空白に
それぞれ新しいデータを埋めていきたいです。
（②に新たに追加注文が確定した果物と出荷日を①の空白行に追加していく）

シートの1行目から10行目までのセルには空白が含まれます。
更新する果物の名前は完全一致の場合とします。
新たに更新される果物の名前は他とかぶらないものとします。


お詳しい方、宜しくお願いいたします。

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

• 補足します。
  ①の列の並び変えはしないで日付のみ更新したいです。

    補足日時：2021/08/01 09:35

• 画像は更新前です、「もも」「マンゴー」が新たに追加されています。
  逆のパターンはありえます、その場合は①に既存のデータはそのまま残しです
  。
  気づきませんでした、ありがとうございます。

  No.1の回答に寄せられた補足コメントです。 補足日時：2021/08/01 12:14

No.4 ベストアンサー 回答者： めぐみん_ 回答日時： 2021/08/05 09:43

こうでしょうか？

Sub megu_2()
Dim myDic As Object
Dim r As Range, rr As Range, rs As Range

Set myDic = CreateObject("Scripting.Dictionary")

Set rr = Range("L11", Cells(Rows.Count, "L").End(xlUp))
Set rs = Range("I11", Cells(Rows.Count, "I").End(xlUp))

' Ｌ又はＬ・Ｍ列の背景色をすべて消す。ただしどちらかのコードを選んでね！
rr.Interior.ColorIndex = 0 'Ｌ列のみの場合
'rr.Resize(, 2).Interior.ColorIndex = 0 'Ｌ・Ｍ列の場合先頭の'と上の１行を削除

For Each r In rr
myDic.Add r.Value, r.Offset(, 1).Value

'Ｌ列にあってＩ列にない場合
If WorksheetFunction.CountIf(rs, r.Value) = 0 Then
'Ｌ又はＬ・Ｍ列の背景色を赤くする。ただしどちらかのコードを選んでね！
r.Interior.ColorIndex = 3 'Ｌ列のみの場合
'r.Resize(, 2).Interior.ColorIndex = 3 'Ｌ・Ｍ列の場合先頭の'と上の１行を削除
End If
Next

For Each r In rs
If myDic.Exists(r.Value) Then
r.Offset(, -3).Value = myDic(r.Value)
End If
Next

Set myDic = Nothing
Set rr = Nothing
Set rs = Nothing

End Sub

この回答へのお礼

完璧です！ありがとうございました❗

お礼日時：2021/08/06 07:46

No.3 回答者： めぐみん_ 回答日時： 2021/08/01 14:34

事前に日付の書式設定は変更されているとして。

（ m/d に）

Sub megu()
Dim myDic As Object, key
Dim r As Range, rr As Range

Set myDic = CreateObject("Scripting.Dictionary")

For Each r In Range("L11", Cells(Rows.Count, "L").End(xlUp))
myDic.Add r.Value, r.Offset(, 1).Value
Next

For Each r In Range("I11", Cells(Rows.Count, "I").End(xlUp))
Set rr = r.Offset(1)

If myDic.Exists(r.Value) Then
r.Offset(, -3).Value = myDic(r.Value)
myDic.Remove (r.Value)
End If
Next

If myDic.Count > 0 Then
For Each key In myDic.Keys
rr.Value = key
rr.Offset(, -3).Value = myDic(key)
Set rr = rr.Offset(1)
Next
End If

Set myDic = Nothing
Set rr = Nothing

End Sub

なんかもうちょっと纏められそうな感じですが初級レベルなジジィには厳しくて。。。

この回答へのお礼

分かりやすく、とても良くまとまったコードありがとうございます。
大変申し訳ありません。「②に新たに追加注文が確定した～」の部分ですが、①の空白行ではなく、移動させずにそのままの状態でセルの色だけ赤くできませんでしょうか？
画像では分かりやすく色分けしているだけなので、実際は塗り潰し無しです。

お礼日時：2021/08/04 08:09

No.2 回答者： tatsumaru77 回答日時： 2021/08/01 12:54

以下のマクロを標準モジュールに登録してください。

シートを直接更新するので、念のため、バックアップをとってから実行してください。

Option Explicit

Public Sub 確定納期設定()
Dim ws As Worksheet
Dim dicT As Object '連想配列（キー：品名）（値：品番）
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim newrow As Long
Dim row1 As Long
Dim row2 As Long
Dim key As Variant
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set ws = ActiveSheet
maxrow1 = ws.Cells(Rows.Count, "I").End(xlUp).Row 'I列の最大行取得
maxrow2 = ws.Cells(Rows.Count, "L").End(xlUp).Row 'L列の最大行取得
For row1 = 11 To maxrow1
key = ws.Cells(row1, "I").Value
dicT(key) = row1
Next
newrow = maxrow1 + 1
For row2 = 11 To maxrow2
key = ws.Cells(row2, "L").Value
If dicT.exists(key) = True Then
row1 = dicT(key)
ws.Cells(row1, "F").Value = ws.Cells(row2, "M").Value
Else
ws.Cells(newrow, "I").Value = ws.Cells(row2, "L").Value
ws.Cells(newrow, "F").Value = ws.Cells(row2, "M").Value
newrow = newrow + 1
End If
Next

End Sub

この回答へのお礼

検証に時間がかかりご連絡遅れました！動作できました。
ありがとうございます。

お礼日時：2021/08/04 07:59

No.1 回答者： めぐみん_ 回答日時： 2021/08/01 11:30

＞②に①に存在しない新たなデータがあった場合、①I列11行目以降、F列11行目以降の空白にそれぞれ新しいデータを埋めていきたいです。

画像は更新前って事でしょうか？
⇒『マンゴー』が気になってますので。

それと逆のパターン（②に存在しなくて①に存在している）のケースはありませんか？