Excel VBA質問箱 IV

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

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


29111 / 76732 ←次へ | 前へ→

【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
1 hits

【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 お礼

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