[[20231030003301]]　『一致するものがあれば上書き（更新）なければ追加』（りり）　ページの最後に飛ぶ

『一致するものがあれば上書き（更新）なければ追加する方法』（りり）

シート1のA1にIDを入力します
シート1のA列からD列までの5行目からデータを入力します
VBAを使い、シート2のA列にIDと同じ値がある場合は
シート2のA列からD列にシート1の同じIDのデータを上書き、
同じ値がなければシート2の最終行にそれぞれ追加するにはどうしたらいいですか？

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

おはようございます。＾＾
ご説明に矛盾点が有る様に思うのですが。
シート1
シート2
の詳細を今少し解りやすく表形式で数行分でもいいので
お示し戴ければ何かお手伝い出来るかもしれません。
　　↑　。。。多分ですが。。。＾＾；
ちなみに、シート1のA1がIDなら、A5、A6、A7には何がはいるのですか？?;
それともシート1はA1と
一行[5行目]だけの入力用セルなのでせうかね。(*^^*)
m(__)m
（隠居Z） 2023/10/30(月) 09:03:23

 こんな事なのかな。

 Sub Sample()
     Dim App As Application
     Dim ws1 As Worksheet, ws2 As Worksheet
     Dim IDPos1, IDPos2

     Set App = Application
     Set ws1 = Worksheets("Sheet1")
     Set ws2 = Worksheets("Sheet2")

     With ws1
         IDPos1 = App.Match(.Range("A1"), .Range("A5", .Cells(.Rows.Count, "A").End(xlUp)), 0)
     End With

     If IsNumeric(IDPos1) Then
         IDPos1 = IDPos1 + 4
         IDPos2 = App.Match(ws1.Range("A1"), ws2.Columns("A"), 0)

         If IsNumeric(IDPos2) Then '上書き処理
             ws2.Cells(IDPos2, "A").Resize(, 4) = ws1.Cells(IDPos1, "A").Resize(, 4).Value
         Else '追加処理
             ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 4) = _
                                                     ws1.Cells(IDPos1, 1).Resize(, 4).Value
         End If
     Else
         MsgBox "Sheet1に" & ws1.Range("A1").Value & "のIDは存在しません"
     End If
 End Sub

（半平太） 2023/10/30(月) 09:39:01

 いちいちA1セルにIDを入れるのって面倒な気がしないでもないなぁ・・
 狙いのIDを直接右クリックして起動した方が話が早そう。
 そうすれば、自シート内の存在確認も必要なくなるし。

 ま、どう使うのかはっきり分からないので、確信は持てないけども。

（半平太） 2023/10/30(月) 09:48:25

なるほど。。。かもですね。。。＾＾
ありがとうございます。
m(__)m
（隠居Z） 2023/10/30(月) 10:20:20

Option Explicit

Sub Sample()

    Dim ws1 As Worksheet
    Dim ID As Variant

    Set ws1 = Worksheets("Sheet1")
    ID = ws1.Range("A1").Value

    Dim pos As Long

    On Error GoTo ErrTrap
    With Worksheets("Sheet2")
        pos = WorksheetFunction.Match(ID, .Range("A:A"), 0)
        .Cells(pos, "A").Resize(, 4).Value = ws1.Range("A1").Resize(, 4).Value

        Exit Sub
ErrTrap:
        pos = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        Resume Next
    End With

End Sub

これだけで良くないっすか
（ 'ふ'） 2023/10/30(月) 13:10:14

コメント返信：

[ 一覧(最新更新順) ]

[[20231030003301]] 『一致するものがあれば上書き（更新）なければ追加』（りり） ページの最後に飛ぶ

[[20231030003301]]　『一致するものがあれば上書き（更新）なければ追加』（りり）　ページの最後に飛ぶ