[[20090525192802]]　『二つのシートの比較→差異のある部分を上書き/新求x（あらじお）　ページの最後に飛ぶ

『二つのシートの比較→差異のある部分を上書き/新規の行を追加』（あらじお）

こんばんわ。
お忙しいところ申し訳ありませんが、ご教授ください。

現在、マクロ（VBA）を作成したいと考えております。

作成したい動作は以下です。

１．シート1（旧）とシート2（新）を比較。

２．比較結果、シート1と異なるシート2の情報をシート1に上書き
　　※列"AL"は、上書きせず、そのままシート1の情報としたいです。

３．シート2で新たに行が追加された場合、シート1と同一の行に挿入し追加

シートの構成は、以下のようになっております。

○シート1

  A    B 　　C 　　  D 　　　E   　F・・・・AL    AM   AN
1 No. 分類 取引先  担当者 　金額            備考
2 1   00    A社　　○さん　 10000
3 2   02　　B社　　×さん    9000
4 3   01　　C社　　△さん   15000
5 4   03　　B社　　○さん   20000
6 5   05　　D社　　○さん   50000
7 6   02　　A社　　×さん   60000
8 7   07　　C社　　△さん    7500
9 8   07　　D社　　×さん   65000

○シート2

   A    B 　　C 　　  D 　　　E   　F・・・・AL   AM   AN
1  No. 分類 取引先  担当者 　金額            備考
2  1   00    A社　　○さん　 10000
3  2   99　　B社　　■さん     300　　　　　←情報が変更された行
4  9   11    X社　　◎さん　 90000　　　　　←新たに情報が追加された行
5  3   01　　C社　　△さん   15000　　　　　
6  4   03　　B社　　○さん   20000
7  5   05　　D社　　○さん   50000
8  6   02　　A社　　×さん   60000
9  7   07　　C社　　△さん    7500
10 8   07　　D社　　×さん   65000

○マクロ実行後のシート1のデータ

  A    B 　　C 　　  D 　　　E   　F・・・・・・・・・ AN
1 No. 分類 取引先  担当者 　金額
2 1   00    A社　　○さん　 10000
3 2   99　　B社　　■さん     300　　　　　 ←シート2の情報を上書き
4 9   11    X社　　◎さん　 90000　　　 　　←セル2で追加された行を挿入追加
4 3   01　　C社　　△さん   15000
5 4   03　　B社　　○さん   20000
6 5   05　　D社　　○さん   50000
7 6   02　　A社　　×さん   60000
8 7   07　　C社　　△さん    7500
9 8   07　　D社　　×さん   65000

 シート２のAL列が右端列ですか？
まあ、そうであったとして。
　
シート２のAM列が作業列として使えるとして。
AM2に　=IF(COUNTIF(シート1!A:A,A2),VLOOKUP(A2,シート1!A:AL,COLUMN(AL2),FALSE),AL2)
などの式を入力して、AM列の必要範囲にフィルコピー。
シート1のAL列とシート2の新規データのAL列の統合データを作る。
シート２のA:AK列までをシート１の同じ範囲にコピー貼り付け。
シート２のAM列をコピー、シート１のAM列に「形式を選択して貼り付け」の「値貼り付け」。
　
こんな感じではいかがでしょうか。
マクロの記録でおおまかな部分ができます。
(みやほりん)(-_∂)b
　
追記：Noに重複がない、シート２で削除されてしまうデータがない
　　　というのが前提です。言及がないので。

(みやほりん)(-_∂)bさん＞

ご回答頂き、ありがとうございます。

シート1,2ともにAN列が右端列となります。

また、Noの箇所は、シート1,2で重複している箇所が多数あり、
シート2で削除されてしまったり、行が追加されたりするデータもあります。

 ＞Noの箇所は、シート1,2で重複している箇所が多数あり
 すると、どこを見てデータが書き変わっていると判断すれば良いのでしょう？

 ＞シート2で削除されてしまったり、行が追加されたりするデータもあります。 
 となると
 「３．シート2で新たに行が追加された場合、シート1と同一の行に挿入し追加」
 何を基準に「同一の行」とするのでしょう？

 シート2で削除された行はシート1には残っているのですよね・・・？

 ＞シート1,2ともにAN列が右端列となります。 
 それらの全ての列が変わっている可能性が有り
 AL列以外はシート1の状態に成れば良いのですか？

 シート1をシート2の情報に更新するのではなく
 シート2のALW列をシート1のAL列に更新して
 シート1に貼り付けるのが簡単かもしれませんね。

 ・・・って、みやほりんさんの案と同じですね。

 ＞Noの箇所は、シート1,2で重複している箇所が多数あり、シート2で削除されてしまったり
 この辺りの扱いをもう少し詳しく説明してみられてはどうでしょう。

 (HANA)

HANAさん＞

ご連絡が遅くなり、申し訳ありません。

色々とコメント頂いたにも関わらず申し訳ありませんが、
現状、以下の作業で困っております。

■シート1とシート2のA列を比較し、値が一致していなかったら、
　シート1の比較している行の下に行を挿入し、値をコピーする。

具体的には、以下の形式になる事を考えております。

○シート1

  A    B 　　C 　　  D 　　　E   　F・・・・AL  AM   AN
  No. 分類 取引先  担当者 　金額            　　
1 1   00    A社　　○さん　 10000
2 2   02　　B社　　×さん    9000
3 3   01　　C社　　△さん   15000

○シート2

   A    B 　　C 　　  D 　　　E   　F・・・・AL   AM   AN
   No. 分類 取引先  担当者 　金額            
1  1   00    A社　　○さん　 10000
2  2   02　　B社　　×さん    9000　　　
3  9   11    X社　　◎さん　 90000　　　　　←新たに追加された行
4  3   01　　C社　　△さん   15000

シート1とシート2のA列を比較 →シート1,2のA3の値が異なる。

○マクロ実行後のシート1のデータ

  A    B 　　C 　　  D 　　　E   　F・・・・・・・・・ AN
  No. 分類 取引先  担当者 　金額
1 1   00    A社　　○さん　 10000
2 2   02　　B社　　×さん    9000
3 9   11    X社　　◎さん　 90000　　　 　　←A列の値が異なるため、行を挿入コピー
4 3   01　　C社　　△さん   15000

※行に関しては、シート1,2ともに200行程度あります。
※シート2に新たに追加される行はランダムです。

 それで、削除されることは無いのですかね？

 Sheet1
  A    B 　　C 　　  D 　　　E   　F・・・・AL    AM   AN
1 No. 分類 取引先  担当者 　金額            備考
2 1   00    A社　　○さん　 10000
3 2   02　　B社　　×さん    9000
4 3   01　　C社　　△さん   15000
5 4   03　　B社　　○さん   20000
6 5   05　　D社　　○さん   50000
7 6   02　　A社　　×さん   60000
8 7   07　　C社　　△さん    7500
9 8   07　　D社　　×さん   65000

 Sheet2
  A    B 　　C 　　  D 　　　E   　F・・・・AL    AM   AN
1 No. 分類 取引先  担当者 　金額            備考
2 1   00    A社　　○さん　 10000
3 2   02　　B社　　×さん    9000   ★No.3 削除
4 4   03　　B社　　○さん   20000
5 5   05　　D社　　○さん   50000
6 9   11    X社　　◎さん　 90000   ☆No.9 追加
7 6   02　　A社　　×さん   60000
8 7   07　　C社　　△さん    7500
9 8   07　　D社　　×さん   65000

 Sheet1のA列を上から順にみていくと
 「2」の次は「3」に成る必要が有るのに、
 Sheet2では「4」に成っています。
 でも、これは追加された訳ではありません。

 削除されることが無いなら、上から順に見比べるだけで良いのですが。

 (HANA)

 追加・変更がそう無いと希望して・・・

 '------
Sub bay_salt()
Dim sn1 As String, sn2 As String, md As String
Dim mr1 As Long, mr2 As Long, t2r As Long
Dim i As Long, ii As Long
Dim dic, tbl1, tbl2
    sn1 = "Sheet1"  '←変更シート名変更
    sn2 = "Sheet2"  '←新データシート名変更
Set dic = CreateObject("scripting.dictionary")
    With Sheets(sn2)
        mr2 = .Range("A" & Rows.Count).End(xlUp).Row
        tbl2 = .Range("A1:AN" & mr2)
        For i = 2 To mr2
            For ii = 2 To 37
                md = md & "_" & tbl2(i, ii)
            Next
                md = md & "_" & tbl2(i, 39) & "_" & tbl2(i, 40)
            dic(tbl2(i, 1)) = Array(i, md)
            md = ""
        Next
    End With
With Sheets(sn1)
    mr1 = .Range("A" & Rows.Count).End(xlUp).Row
    tbl1 = .Range("A1:AN" & mr1)
    For i = 2 To mr1
        If dic.exists(tbl1(i, 1)) Then
            For ii = 2 To 37
                md = md & "_" & tbl1(i, ii)
            Next
                md = md & "_" & tbl1(i, 39) & "_" & tbl1(i, 40)
            If md <> dic(tbl1(i, 1))(1) Then
                t2r = dic(tbl1(i, 1))(0)
                Sheets(sn2).Range("A" & t2r).Resize(, 37).Copy .Range("A" & i)
                Sheets(sn2).Range("AM" & t2r).Resize(, 2).Copy .Range("AM" & i)
            End If
                md = ""
        End If
    Next
    .Columns("A:A").Insert Shift:=xlToRight
End With
    With Sheets(sn2)
        .Columns("A:A").Insert Shift:=xlToRight
        .Range("A2:A" & mr2).Formula = "=MATCH(B2," & sn1 & "!B:B,0)"
        For i = 2 To mr2
            If IsError(.Range("A" & i).Value) Then
                .Range("A" & i).EntireRow.Copy
                Sheets(sn1).Range("A" & .Range("A" & i + 1).Value).Insert Shift:=xlDown
            End If
        Next
        .Columns("A:A").Delete Shift:=xlToLeft
    End With
Sheets(sn1).Columns("A:A").Delete Shift:=xlToLeft
Set dic = Nothing
End Sub
 '------

 コピーしたファイルで試して下さい。

 (HANA)

コメント返信：

[ 一覧(最新更新順) ]

[[20090525192802]] 『二つのシートの比較→差異のある部分を上書き/新求x（あらじお） ページの最後に飛ぶ

[[20090525192802]]　『二つのシートの比較→差異のある部分を上書き/新求x（あらじお）　ページの最後に飛ぶ