| |
こんばんは。
こんな方法もあるということで・・・。
新規ブックの標準モジュールに
'=============================================================
Sub main()
Dim rngA As Range
Dim rngB As Range
Dim ans As Range
Call mk_sample
MsgBox "このサンプルで追加データ、削除データを表示します"
'実際のデータが準備されていれば、↑上記の2行は削除すること"
Set rngA = Range("a2", Cells(Rows.Count, "a").End(xlUp))
If rngA.Row <= 1 Then Set rngA = [a2]
Set rngB = Range("b2", Cells(Rows.Count, "b").End(xlUp))
If rngB.Row <= 1 Then Set rngB = [b2]
Range("c1:d1").Value = Array("追加No.", "削除No.")
On Error Resume Next
Range("e1").Value = "work"
rngB.Offset(0, 3).Formula = _
"=IF(and(isnumber(b2),ISERROR(MATCH(B2," & rngA.Address & ",0))),B2)"
Set ans = Union(Range("e1"), _
rngB.Offset(0, 3)).SpecialCells(xlCellTypeFormulas, xlNumbers)
If Err.Number = 0 Then
ans.Copy
Range("c2").PasteSpecial xlPasteValues
End If
Err.Clear
Range("e:e").ClearContents
Range("e1").Value = "work"
rngA.Offset(0, 4).Formula = _
"=IF(and(isnumber(a2),ISERROR(MATCH(a2," & rngB.Address & ",0))),a2)"
Set ans = Union(Range("e1"), _
rngA.Offset(0, 4)).SpecialCells(xlCellTypeFormulas, xlNumbers)
If Err.Number = 0 Then
ans.Copy
Range("d2").PasteSpecial xlPasteValues
End If
Range("e:e").ClearContents
Application.CutCopyMode = False
On Error GoTo 0
End Sub
'===================================================================================
Sub mk_sample()
Range("a1:b1").Value = Array("元データ", "追加データ")
Range("a2:b6").Value = _
[{2763,4536;77756,6873;2445,2763;68767,29876;8888,2445}]
End Sub
これでmainを実行してみてください。
サンプルデータもコードで用意していますから、空シートをアクティブにして
試してみてください。
尚、Ｅ列を作業エリアとしてプログラムが使用していますから、注意してください。
作業列を設け（ここではＥ列）、そこに数式をコードで入力します。
数式の結果から条件にあったセルをSpecialCellsメソッドで取得する
というこのサイトでは良く見かける方法です。
|
|
ichinose
- 07/12/9(日) 21:29 -
