Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4943 / 13644 ツリー ←次へ | 前へ→

【52904】二列のデータ比較マクロ作成で困ってます しーちゃん 07/12/8(土) 23:47 質問[未読]
【52905】Re:二列のデータ比較マクロ作成で困ってます かみちゃん 07/12/9(日) 1:05 発言[未読]
【52908】Re:二列のデータ比較マクロ作成で困ってます Hirofumi 07/12/9(日) 8:57 回答[未読]
【52909】Re:二列のデータ比較マクロ作成で困ってます Hirofumi 07/12/9(日) 9:33 回答[未読]
【52940】Re:二列のデータ比較マクロ作成で困ってます ichinose 07/12/9(日) 21:29 発言[未読]
【52945】Re:二列のデータ比較マクロ作成で困ってます じゅんじゅん 07/12/9(日) 22:40 発言[未読]
【53449】Re:二列のデータ比較マクロ作成で困ってます しーちゃん 08/1/13(日) 14:51 お礼[未読]

【52904】二列のデータ比較マクロ作成で困ってます
質問  しーちゃん  - 07/12/8(土) 23:47 -

引用なし
パスワード
   こんばんわ。
VBAを始めてまだ日が浅く、
マクロ作成に悩まされています。。
皆さんのお力をお借りしたく。

A列B列にそれぞれ数字(No.)が入力されており、
A列は旧データ、B列は新データになります。
A列B列を比較して、A列(旧データ)から追加された数字(No.)、
削除された数字(No.)を検出するマクロを作成したいと思っています。

  A     B    追加No.  削除No.
1 2763   4536    4536    77756
2 77756  6873    6873    68767
3 2445   2763    29876   8888
4 68767  29876  
5 8888   2445

上記マクロの作成方法が分からず、困っています。
作成する際に、何度もエラーが出てしまい、進んでいきません。。
例えば、B列の4536を検索しようとすると、A列に45367という数字があると
その数字も追加No.になってしまいます。

何か良いマクロがありましたら、教えて下さい。
宜しくお願い致します。

【52905】Re:二列のデータ比較マクロ作成で困って...
発言  かみちゃん  - 07/12/9(日) 1:05 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>作成する際に、何度もエラーが出てしまい、進んでいきません。。

どのようなマクロでどのようなエラーが出ているのでしょうか?
そのコードを提示することはできませんか?
恥ずかしくてもいいのです。最初は、みんな一緒ですから。

【52908】Re:二列のデータ比較マクロ作成で困って...
回答  Hirofumi  - 07/12/9(日) 8:57 -

引用なし
パスワード
   こんな物かな?
A列、B列には、列見出しが有る物とします
結果はC列、D列に出力される物とします

Option Explicit

Public Sub DataMatch()

  '「A列」のデータ列数(A列)
  Const clngColumns1 As Long = 1
  '「A列」の比較する列の列位置
  '(基準セル位置からの列Offset:A列)
  Const clngKeys1 As Long = 0
  
  '「B列」のデータ列数(B列)
  Const clngColumns2 As Long = 1
  '「B列」の比較する列の列位置
  '(基準セル位置からの列Offset:B列)
  Const clngKeys2 As Long = 0
  
  Dim rngList1 As Range
  Dim vntList1 As Variant
  Dim lngRows1 As Long
  Dim lngComp1 As Long
  Dim rngList2 As Range
  Dim vntList2 As Variant
  Dim lngRows2 As Long
  Dim lngComp2 As Long
  Dim lngMatch As Long
  Dim rngResult As Range
  Dim vntAppend As Variant
  Dim lngAppend As Long
  Dim vntDelete As Variant
  Dim lngDelete As Long
  Dim strProm As String

  '「A列」のA1を基準とします(列見出しが有るとします)
  Set rngList1 = ActiveSheet.Cells(1, "A")
  
  '「B列」のB1を基準とする(列見出しが有るとします)
  Set rngList2 = ActiveSheet.Cells(1, "B")
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '「A列」の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, _
      clngColumns1, clngKeys1, vntList1) Then
    strProm = rngList1.Value & "にデータが有りません"
    GoTo Wayout
  End If
  
  '「B列」基準に就いて
  If Not GetBasicData(rngList2, lngRows2, _
      clngColumns2, clngKeys2, vntList2) Then
    strProm = rngList2.Value & "にデータが有りません"
    GoTo Wayout
  End If
  
  '「結果出力」の位置を指定します
  Set rngResult = ActiveSheet.Cells(1, "C")
  '出力用配列を確保します
  ReDim vntAppend(lngRows2, 1 To 1), _
      vntDelete(lngRows1, 1 To 1)
  '列見出しを出力
  vntAppend(0, 1) = "追加No."
  vntDelete(0, 1) = "削除No."
  
  '「A列」の比較位置
  lngComp1 = 1
  '「B列」の比較位置
  lngComp2 = 1
  '「A列」「B列」が共に最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '各列のデータを比較
    lngMatch = DataCompare(vntList1, _
          lngComp1, vntList2, lngComp2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        '「A列」の比較位置を更新
        lngComp1 = lngComp1 + 1
        '「B列」の比較位置を更新
        lngComp2 = lngComp2 + 1
      Case Is = -1 '「A列」の固有値の場合
        'データを配列に出力
        lngDelete = lngDelete + 1
        vntDelete(lngDelete, 1) = vntList1(lngComp1, 1)
        '「A列」のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 '「B列」の固有値の場合
        'データを配列に出力
        lngAppend = lngAppend + 1
        vntAppend(lngAppend, 1) = vntList2(lngComp2, 1)
        '「B列」の比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  '"追加No."数、"削除No."数で大きい方の行数分を取得します
  If lngAppend > lngDelete Then
    lngRows1 = lngAppend
  Else
    lngRows1 = lngDelete
  End If
  With rngResult
    '出力範囲をクリア
    .Resize(, 2).EntireColumn.Clear
    '結果を出力
    .Resize(lngRows1 + 1).Value = vntAppend
    .Offset(, 1).Resize(lngRows1 + 1).Value = vntDelete
  End With

  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                lngKeys As Long, _
                vntData As Variant) As Boolean

  Dim i As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(.Parent.Rows.Count _
        - .Row, lngKeys).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    'データをlngKeys列で整列
    DataSort .Offset(1).Resize(lngRows, _
        lngColumns), .Offset(1, lngKeys)
    '比較用配列にデータを取得
    vntData = .Offset(1, lngKeys) _
          .Resize(lngRows + 1).Value
  End With
  
  GetBasicData = True

End Function

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _
              vntKeys2 As Variant, lngPos2 As Long) As Long

'  データの大小比較

  Dim i As Long
  
  '比較位置がDataEndを超えた場合
  If lngPos1 > UBound(vntKeys1, 1) - 1 Then
    DataCompare = 1
    Exit Function
  End If
  If lngPos2 > UBound(vntKeys2, 1) - 1 Then
    DataCompare = -1
    Exit Function
  End If
    
  'もし、Keyが不一致なら
  If vntKeys1(lngPos1, 1) = vntKeys2(lngPos2, 1) Then
    '戻り値の値として、「等しい」を返す
    DataCompare = 0
  Else
    'vntKeys1の値が、vntKeys2の値因り小さい場合
    If vntKeys1(lngPos1, 1) < vntKeys2(lngPos2, 1) Then
      '戻り値の値として、「小さい」を返す
      DataCompare = -1
    Else
      '戻り値の値として、「大きい」を返す
      DataCompare = 1
    End If
  End If
  
End Function

【52909】Re:二列のデータ比較マクロ作成で困って...
回答  Hirofumi  - 07/12/9(日) 9:33 -

引用なし
パスワード
   ごめん、以下を勘違いで、間違った為に修正して下さい

修正が必要なコード

  '"追加No."数、"削除No."数で大きい方の行数分を取得します
  If lngAppend > lngDelete Then
    lngRows1 = lngAppend
  Else
    lngRows1 = lngDelete
  End If
  With rngResult
    '出力範囲をクリア
    .Resize(, 2).EntireColumn.Clear
    '結果を出力
    .Resize(lngRows1 + 1).Value = vntAppend
    .Offset(, 1).Resize(lngRows1 + 1).Value = vntDelete
  End With

上記部分を以下の修正コードに差し替えてください

  With rngResult
    '出力範囲をクリア
    .Resize(, 2).EntireColumn.Clear
    '結果を出力
    .Resize(lngAppend + 1).Value = vntAppend
    .Offset(, 1).Resize(lngDelete + 1).Value = vntDelete
  End With

以上

【52940】Re:二列のデータ比較マクロ作成で困って...
発言  ichinose  - 07/12/9(日) 21:29 -

引用なし
パスワード
   こんばんは。
こんな方法もあるということで・・・。

新規ブックの標準モジュールに
'=============================================================
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を実行してみてください。

サンプルデータもコードで用意していますから、空シートをアクティブにして
試してみてください。
尚、E列を作業エリアとしてプログラムが使用していますから、注意してください。

作業列を設け(ここではE列)、そこに数式をコードで入力します。
数式の結果から条件にあったセルをSpecialCellsメソッドで取得する
というこのサイトでは良く見かける方法です。

【52945】Re:二列のデータ比較マクロ作成で困って...
発言  じゅんじゅん  - 07/12/9(日) 22:40 -

引用なし
パスワード
   私も参考になればと言うレベルですが。
1行目は項目行扱いとしてます。

Sub test()
Dim Dic As Object
Dim a, b, v, vv
Dim i As Long

Set Dic = CreateObject("Scripting.Dictionary")
i = 2
With Worksheets("Sheet1")
   v = .Range(.[A2], .Cells(Rows.Count, 1).End(xlUp)).Value
    For Each vv In v
      Dic(vv) = Empty
    Next
   .Range("C:D").ClearContents
   a = .Range(.[B2], .Cells(Rows.Count, 2).End(xlUp)).Value
    For Each b In a
      If Not Dic.exists(b) Then
        .Range("C" & i).Value = b
        i = i + 1
       Else
        Dic.Remove (b)
       End If
    Next
   .Range("D2").Resize(Dic.Count).Value = Application.Transpose(Dic.keys)
   .Range("C1").Resize(, 2).Value = [{"追加No.","削除No."}]
End With
End Sub

(ご希望にあっているかは不安ですけど)

【53449】Re:二列のデータ比較マクロ作成で困って...
お礼  しーちゃん  - 08/1/13(日) 14:51 -

引用なし
パスワード
   みなさんどうもありがとうございました!!
自宅にパソコンが無いので、御礼を言うのがこんなにも遅くなった事をお詫び申し上げます。みなさんのマクロを参考にさせて頂きます。
本当にありがとうございます!
こんなに教えて頂けるとは思っていなかったので、恐縮しております。。
ありがとうございます。

4943 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free