Excel VBA質問箱 IV

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

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


3329 / 13646 ツリー ←次へ | 前へ→

【62874】リストの検索(変更箇所に色をつける) まい 09/9/10(木) 21:21 質問[未読]
【62876】Re:リストの検索(変更箇所に色をつける) Hirofumi 09/9/10(木) 23:22 回答[未読]
【62884】Re:リストの検索(変更箇所に色をつける) arajin 09/9/12(土) 14:33 回答[未読]
【62906】Re:リストの検索(変更箇所に色をつける) まい 09/9/14(月) 20:47 お礼[未読]

【62874】リストの検索(変更箇所に色をつける)
質問  まい  - 09/9/10(木) 21:21 -

引用なし
パスワード
   sheet1とsheet2があります
sheet1は古いデータのリストで、sheets2は最新データのリストとなってます
最新データはデータが増えたり、一部変更が発生したりしています

そこで、新しいリストと古いリストを比べて、変更のあった箇所の色を変える。
ということをしたいのですが、ここで、問題があります
検索するキーとなるものが、一つだったら、Findを使って、Findで見つけた箇所の行の変更箇所を取得することはできますが、

キーとなるものが2つあると、いまいちどうやってマクロを組めばいいのか?
悩んでいます

新しいデータ(sheet2)の同じ行のA列、B列と古いデータ(sheet1)のA列、B列検索し、同じものがあったら、その行で変更している箇所がないかをチェックする。変更があるセルの色を(新しいデータ(sheet2)のほうに色をつける)変える
方法が知りたいです

【sheets1】(古いデータ)
 A   B  C  D  E  F  G
1 AAA A123 in  in  in   
2 BBB A123 out out in
3 CCC B456        in  out
4 DDD C123   in  in
5 DDD D123 out      out

【sheets2】(最新データ)
 A   B  C  D  E  F  G
1 AAA A123    in  in   
2 AAA F456 in       in
3 BBB A123 in  out in
4 CCC B456        in  out
5 DDD C123   out  in
6 DDD D123 out      out
7 EEE E123 in  in
 
例えば、上記の表があるとします
見比べて、変更箇所は、
【C1】と【C3】と【D5】です。この部分の色を変えたいのです

又、新しく追加になったデータがあれば、(古いデータに載ってないもの)
その行をAからGまで、色を付けたいと思っています
(例:追加分の2行目と7行目に色をつけたいです)


どうか、アドバイスをお願いします

【62876】Re:リストの検索(変更箇所に色をつける)
回答  Hirofumi  - 09/9/10(木) 23:22 -

引用なし
パスワード
   両シート共に列見出しが有る物とします
サンプルでは、両List共にA1がリストの先頭列見出しとします

Option Explicit
'Option Compare Text '比較Keyに全角が含まれる場合は活かす

Public Sub DataMatch()

'  固有データのチェック

  'Sheet1のデータ列数(A列〜G列)
  Const clngColumns1 As Long = 7
  'Sheet2のデータ列数(A列〜G列)
  Const clngColumns2 As Long = 7
  '比較するセルの先頭位置(基準セルからの列Offsetで指定)
  Const clngStart As Long = 2
  '比較するセルの数
  Const clngAmount As Long = 5
  
  Dim i As Long
  Dim rngList1 As Range
  Dim vntList1 As Variant
  Dim lngRows1 As Long
  Dim lngComp1 As Long
  Dim vntKeys1 As Variant
  Dim vntData1 As Variant
  Dim rngList2 As Range
  Dim vntList2 As Variant
  Dim lngRows2 As Long
  Dim lngComp2 As Long
  Dim vntKeys2 As Variant
  Dim vntData2 As Variant
  Dim lngMatch As Long
  Dim strProm As String

  'Sheet1データシートのA2を基準とします
  Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
  
  'Sheet2データシートのA2を基準とする
  Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
  
  'Sheet1の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys1 = Array(0, 1)
  'Sheet2の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys2 = Array(0, 1)
  
  'Sheet1の比較データを保持する配列を確保
  ReDim vntList1(0 To UBound(vntKeys1))
  'Sheet2の比較データを保持する配列を確保
  ReDim vntList2(0 To UBound(vntKeys1))
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  
  'Sheet1の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Sheet2基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Sheet1のシートの比較位置
  lngComp1 = 1
  'Sheet2のシートの比較位置
  lngComp2 = 1
  'Sheet1のシート若しくは、Sheet2のシートが最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '各列のデータを比較
    lngMatch = DataCompare(vntList1, lngComp1, vntList2, lngComp2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        '両方のデータを取得
        vntData1 = rngList1.Offset(lngComp1, clngStart).Resize(, clngAmount).Value
        vntData2 = rngList2.Offset(lngComp2, clngStart).Resize(, clngAmount).Value
        '両方のデータを比較
        For i = 1 To clngAmount
          '違った場合バックカラーを変更
          If vntData1(1, i) <> vntData2(1, i) Then
            rngList2.Offset(lngComp2, clngStart).Offset(, i - 1) _
                .Interior.ColorIndex = 34
          End If
        Next i
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
      Case Is = -1 'Sheet1の固有値の場合
        'Sheet1のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 'Sheet2の固有値の場合
        '違った場合バックカラーを変更
        rngList2.Offset(lngComp2).Resize(, clngColumns2).Interior.ColorIndex = 34
        'Sheet2のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  'Sheet1のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  
  'Sheet2のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

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

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

  Dim i As Long
  Dim lngNumb() As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    '復帰用整列Keyを作成
    ReDim lngNumb(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用Keyの出力
    .Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
    'データをvntKeys1列で整列
    For i = UBound(vntKeys) To 0 Step -1
      DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, vntKeys(i))
    Next i
    '比較用配列にデータを取得
    For i = 0 To UBound(vntKeys)
      vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
    Next i
  End With
  
  GetBasicData = True

End Function

Private Sub DataRestore(rngList As Range, lngRows As Long, lngColumns As Long)

  With rngList
    '元データ順位を復帰
    DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, lngColumns)
    '復帰用Key列を削除
    .Offset(1, lngColumns).EntireColumn.Delete
  End With

End Sub

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
  Dim lngMax As Long
  
  '比較位置がDataEndを超えた場合
  If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
    DataCompare = 1
    Exit Function
  End If
  If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
    DataCompare = -1
    Exit Function
  End If
    
  '1行の最大比較回数を取得(実際は0から始まる為、回数としては+1と成る)
  lngMax = UBound(vntKeys1, 1)
  
  '1行のKeyを先頭から比較
  For i = 0 To lngMax
    'もし、Keyが不一致なら
    If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
      'Forを抜ける
      Exit For
    End If
  Next i
  
  'Keyが全て一致した場合(Forが全て回り終った場合、iはlngMax+1と成る)
  If i > lngMax Then
    '戻り値の値として、「等しい」を返す
    DataCompare = 0
  Else
    'vntKeys1の値が、vntKeys2の値因り小さい場合
    If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
      '戻り値の値として、「小さい」を返す
      DataCompare = -1
    Else
      '戻り値の値として、「大きい」を返す
      DataCompare = 1
    End If
  End If
  
End Function

【62884】Re:リストの検索(変更箇所に色をつける)
回答  arajin  - 09/9/12(土) 14:33 -

引用なし
パスワード
   あまり深く考えていませんが、配列内にデータを格納しすべて総当りで比較する例です。
途中、Dictionaryを使ってますが、キーとなるA,B列の組み合わせは一意であるという前提です。

Sub 比較()
  Dim RR As Range
  Dim v1 As Variant, v2 As Variant
  Dim dic As Object
  Dim ky As Variant
  Dim i As Long, j As Long, k As Long
  
  Set RR = Worksheets("Sheet2").Range("A1").CurrentRegion.Resize(, 7)
  v1 = Worksheets("Sheet1").Range("A1").CurrentRegion _
                    .Resize(, RR.Columns.Count).Value
  v2 = RR.Value
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To UBound(v1, 1)
    ky = v1(i, 1) & vbTab & v1(i, 2)
    dic.Item(ky) = i
  Next
  For i = 1 To UBound(v2, 1)
    ky = v2(i, 1) & vbTab & v2(i, 2)
    If dic.Exists(ky) Then
      k = dic.Item(ky)
      For j = 3 To UBound(v2, 2)
        If v2(i, j) <> v1(k, j) Then
          RR.Item(i, j).Interior.Color = vbYellow
        End If
      Next
    Else
      RR.Rows(i).Interior.Color = vbBlue
    End If
  Next
  Set dic = Nothing
  Set RR = Nothing
End Sub

【62906】Re:リストの検索(変更箇所に色をつける)
お礼  まい  - 09/9/14(月) 20:47 -

引用なし
パスワード
   ▼Hirofumiさん:
▼arajin さん:

ありがとうございます

なんせド素人ですので、今、解読中です。

また、内容の中で質問等するかもしれませんが、なんとか、考えてみます

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