2023-11-12

【ﾉｰｺｰﾄﾞ】既存データは上書き、新規データは追加する

コピー（データ転記）

エクセルVBAマクロを自動作成する無料アプリです。

例として「既存データは上書き、新規データは追加する」VBAマクロを作成します。

事例　既存データは上書き、新規データは追加します
- アプリの設定
- 表示されるVBAコード
ChatGPTで修正
アプリはこちらから↓↓↓↓

事例　既存データは上書き、新規データは追加します

・左と右の表の1列目と2列目が同じときは、上書きします。

・左の表の1列目と2列目が、右の表に無いときは、新規として末尾に追加します。

マクロを実行すると、データが表に反映されました。

できました😄

【特徴】
・条件と転記は、１セル・複数セルとも対応します（事例は複数セル）
・２つの表のサイズが異なっても対応します。
・列の順番は変えられます。
・別シートや、複数シートへの転記も可能です。

なお、値が一致したら転記のパターンは下記があります😊

パターンを見る

値が一致したら、1行すべてを転記する｜連想配列｜連想配列

値が一致しなければ、１行すべてを転記する｜連想配列

値が一致したら、値の横にデータを転記する｜連想配列

値が一致したら、値の横で既存データは上書きし、新規データは追加する｜連想配列

値が部分一致したら、データを転記する｜フィルター

複数項目を、それぞれ異なる条件で転記する｜フィルターオプション

【ポイント】
・条件と転記の列は、複数にも対応します。
・２つの表のサイズが異なっても対応します。
・列の順番は変えられます。
・別シートや、複数シートへの転記も可能です。

アプリの設定

アプリへのリンク
　⇒値が一致したら既存データは上書き、新規データは追加

表示されるVBAコード

アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。

VBAコードを見る

Sub デモ() '値が一致したら既存データは上書き、新規データは追加
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止
'辞書オブジェクトの作成
Dim 辞書1 As Object, 辞書2 As Object
Set 辞書1 = CreateObject("Scripting.Dictionary")
Set 辞書2 = CreateObject("Scripting.Dictionary")
'転記元の設定
Sheets("Sheet1").Select
Dim 最終行 As Long, 対象セル As Range
最終行 = Cells(Rows.Count, Range("a3").Column).End(xlUp).Row
Set 対象セル = Range("a3" & ":" & Cells(最終行, Range("d3").Column).Address(False, False))
'辞書1の作成
Dim 行 As Range, key1 As Variant
For Each 行 In 対象セル.Rows
key1 = 行.Cells(1, 1) & "|" & 行.Cells(1, 2)
If 辞書1.Exists(key1) Then
行.Select
MsgBox "選択した箇所に重複があるので終了します"
Exit Sub
Else
辞書1(key1) = 行.Cells(1, 3) & "|" & 行.Cells(1, 4)
End If
Next
'転記先シートの選択
Sheets("Sheet1").Select
'転記先セルの設定
Dim 最終行2 As Long
最終行2 = Cells(Rows.Count, Range("f3").Column).Offset(0, 1 - 1).End(xlUp).Row
Set 対象セル = Range("f3" & ":" & Cells(最終行2, Range("i3").Column).Address(False, False))
'既存上書き
Dim key2 As Variant
For Each 行 In 対象セル.Rows
key2 = 行.Cells(1, 1) & "|" & 行.Cells(1, 2)
If 辞書2.Exists(key2) Then
行.Select
MsgBox "選択した箇所に重複があるので終了します"
Exit Sub
Else
辞書2(key2) = ""
Dim 値 As Variant
If 辞書1.Exists(key2) Then
値 = Split(辞書1(key2), "|")
行.Cells(1, 3) = 値(0)
行.Cells(1, 4) = 値(1)
End If
End If
Next
'新規追加
For Each key1 In 辞書1.Keys()
If Not 辞書2.Exists(key1) Then
最終行2 = 最終行2 + 1
値 = Split(key1, "|")
Cells(最終行2, Range("f3").Column).Cells(1, 1) = 値(0)
Cells(最終行2, Range("f3").Column).Cells(1, 2) = 値(1)
値 = Split(辞書1(key1), "|")
Cells(最終行2, Range("f3").Column).Cells(1, 3) = 値(0)
Cells(最終行2, Range("f3").Column).Cells(1, 4) = 値(1)
End If
Next key1
'Application.ScreenUpdatingとApplication.DisplayAlertsをTrueに戻す
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub