Excel VBA質問箱 IV

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

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


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

【44281】シートの比較、ご教授下さい。(再記載) ドルフィン 06/11/12(日) 0:24 お礼[未読]
【44283】Re:シートの比較、ご教授下さい。(再記載) ドルフィン 06/11/12(日) 0:33 発言[未読]
【44288】Re:シートの比較、ご教授下さい。(再記載) ichinose 06/11/12(日) 8:21 発言[未読]
【44296】Re:シートの比較、ご教授下さい。(再記載) ドルフィン 06/11/12(日) 12:08 お礼[未読]
【44287】Re:シートの比較、ご教授下さい。(再記載) Hirofumi 06/11/12(日) 3:07 回答[未読]
【44295】Re:シートの比較、ご教授下さい。(再記載) ドルフィン 06/11/12(日) 11:52 お礼[未読]

【44281】シートの比較、ご教授下さい。(再記載)
お礼  ドルフィン  - 06/11/12(日) 0:24 -

引用なし
パスワード
   シート比較、ご教授下さいm( _ _ )m
どなたかご教示下さい。vba初心者です。
以下のようなSheet1とSheet2があります。

この2つのシートを比較して、Sheet3に比較結果を書き出します。
ですが、以下に記載したプログラムを実行すると、結果[Sheet3]の
5、7行目の項目1〜8のセルの背景色が赤く表示されてしまいます。
結果の値の出力は仕様通り表示されています。
―――――――――――――――――――――――――――
◆(とらん)
  A    B    C  D  E  F  G  H  I  J  K
1|コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1001  101   A  1  1  1  1  1  1  1  1
3|2001  202   U  2  2  2  2  2  2  2  2
4|3001  303   U  3  3  3  3  3  3  3  3

◆(ますた)
  A    B    C  D  E  F  G  H  I  J  K
1|コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1001  101     1  1  1  1  1  1  1  1
3|1001  101     1  1  1  1  1  1  1  1
3|2001  202     2  2  2  2  2  2  2  2
4|3001  303     3  3  3  3  3  3  3  3

◆(結果)
1|Sheet  コード1 コード2 記号 項1 項2 項3 項4 項5 項6 項7 項8
2|1    1001  101   A  1  1  1  1  1  1  1  1
3|2    1001  101      1  1  1  1  1  1  1  1
4|1    2001  202   U  2  2  2  2  2  2  2  2
5|2    2001  202      2  2  2  2  2  2  2  2
6|1    3001  303   U  3  3  3  3  3  3  3  3
7|2    3001  303      3  3  3  3  3  3  3  3
―仕様――――――――――――――――――――――――――
1)「とらん」を1件づつ読込み、コード1とコード2をキーに「ますた」を検索し、

  『とらん』「記号」="A"の場合

  ◆存在した場合、項目1,2,3を比較し、「とらん」と「ますた」の情報を
   [Sheet3]に結果を書き出します。
   「ますた」に複数存在した場合は1件目のレコードで比較します。
   アンマッチ項目があった場合、その項目のセルを赤く表示します。

  ◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
   結果を書き出し、マスタのキーエリアに"*"を設定し、セルを赤く。

  『とらん』「記号」="D"の場合

  ◆存在しなかった場合、「とらん」のレコードはそのまま[Sheet3]に
   結果を書き出し、「ますた」はキーエリアに"-"を設定します。

  ◆存在した場合、[Sheet3]に結果を書き出します。
   「ますた」に複数存在した場合は1件目のレコードで比較します。
   アンマッチ項目があった場合、その項目のセルを赤く表示します。

  以上を「とらん」のレコードがなくなるまで繰り返します。
 ※「とらん」は十件程度です。「とらん」がゼロ件の場合は処理を行いません

----
どなたか解る方がいらっしゃいましたら、ご教授の程、宜しくお願い致します。
  
―プログラム――――――――――――――――――――――――――
Sub 実行()
  Dim sh1rng As Range
  Dim sh2rng As Range
  Dim addA As String
  Dim addB As String
  Dim sh2strw As Long
  Dim idx As Long
  Dim rw As Variant
  Dim nsign As String
  '↓本文
  With Worksheets("sheet1")
    Set sh1rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
    End With
  If sh1rng.Row > 1 Then
    With Worksheets("sheet2")
     Set sh2rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
     sh2strw = sh2rng.Row
     If sh2strw > 1 Then
       addA = sh2rng.Address(, , , True)
       addB = sh2rng.Offset(0, 1).Address(, , , True)
       End If
     End With
    For idx = 1 To sh1rng.Count
     rw = CVErr(xlErrNA)
     If sh2strw > 1 Then
       rw = Evaluate("=match(1,(" & addA & "=" & sh1rng.Cells(idx) & _
             ")*(" & addB & "=" & sh1rng.Offset(0, 1).Cells(idx) & _
             "),0)")
       '↑検索
       End If
     With Worksheets("sheet3")
       .Cells(idx * 2, 1).Value = 1
       .Range(.Cells(idx * 2, 2), .Cells(idx * 2, 12)).Value = sh1rng(idx).Resize(, 11).Value
       .Cells(idx * 2 + 1, 1).Value = 2
       If IsError(rw) Then
        Select Case sh1rng(idx, 3).Value
         Case "D":
            nsign = "-"
         Case Else:
            nsign = "*"
            .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
        End Select
        .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Value = nsign
       Else
        Select Case sh1rng(idx, 3).Value
          Case "A", "U":
            If sh1rng(idx, 4).Value <> sh2rng(idx, 4).Value Then
             .Range(.Cells(idx * 2 + 1, 5), .Cells(idx * 2 + 1, 5)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 5).Value <> sh2rng(idx, 5).Value Then
             .Range(.Cells(idx * 2 + 1, 6), .Cells(idx * 2 + 1, 6)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 6).Value <> sh2rng(idx, 6).Value Then
             .Range(.Cells(idx * 2 + 1, 7), .Cells(idx * 2 + 1, 7)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 7).Value <> sh2rng(idx, 7).Value Then
             .Range(.Cells(idx * 2 + 1, 8), .Cells(idx * 2 + 1, 8)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 8).Value <> sh2rng(idx, 8).Value Then
             .Range(.Cells(idx * 2 + 1, 9), .Cells(idx * 2 + 1, 9)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 9).Value <> sh2rng(idx, 9).Value Then
             .Range(.Cells(idx * 2 + 1, 10), .Cells(idx * 2 + 1, 10)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 10).Value <> sh2rng(idx, 10).Value Then
             .Range(.Cells(idx * 2 + 1, 11), .Cells(idx * 2 + 1, 11)).Interior.ColorIndex = 3
            End If
            If sh1rng(idx, 11).Value <> sh2rng(idx, 11).Value Then
             .Range(.Cells(idx * 2 + 1, 12), .Cells(idx * 2 + 1, 12)).Interior.ColorIndex = 3
            End If
            .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
         Case Else:
          .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
          .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
        End Select
       End If
       End With
     Next
    End If
End Sub

-----
以上です。
それでは失礼致します。

【44283】Re:シートの比較、ご教授下さい。(再記...
発言  ドルフィン  - 06/11/12(日) 0:33 -

引用なし
パスワード
   ▼ドルフィン さん:

訂正です。
仕様は以下の2点が誤っていました。

 1.誤:『とらん』「記号」="A" の場合
  正:『とらん』「記号」="A"or"U" の場合
 2.誤:◆存在した場合、項目1,2,3を比較
  正:◆存在した場合、項目1,2,3,4,5,6,7を比較

>―仕様――――――――――――――――――――――――――
>1)「とらん」を1件づつ読込み、コード1とコード2をキーに「ますた」を検索し、
>
>  『とらん』「記号」="A"の場合
>>>  『とらん』「記号」="A"or"U" の場合
>
>  ◆存在した場合、項目1,2,3を比較し、「とらん」と「ますた」の情報を
>>>  ◆存在した場合、項目1-8を比較し、「とらん」と「ますた」の情報を
-----------------------------------------------------------

以上です。
どなたか解る方がいらっしゃいましたら、ご教授下さい。
それでは失礼致します。

【44287】Re:シートの比較、ご教授下さい。(再記...
回答  Hirofumi  - 06/11/12(日) 3:07 -

引用なし
パスワード
   コードが違いますがこんなでは?
以下を、標準モジュールに全て記述して下さい

Option Explicit
Option Compare Text

Public Sub DataMatch()

  Const cstrMarkA As String = "A"
  Const cstrMarkU As String = "U"  
  '「とらん」のデータ列数(A列〜K列)
  Const clngColumns1 As Long = 11
  '「記号」列位置(基準セルからの列Offset:C列)
  Const clngSymbol As Long = 2
  '「ますた」のデータ列数(A列〜K列)
  Const clngColumns2 As Long = 11
  
  Dim i As Long
  Dim rngList1 As Range, rngList2 As Range
  Dim vntList1 As Variant, vntList2 As Variant
  Dim lngRows1 As Long, lngRows2 As Long
  Dim lngComp1 As Long, lngComp2 As Long
  Dim vntKeys1 As Variant, vntKeys2 As Variant
  Dim vntData1 As Variant, vntData2 As Variant
  Dim lngMatch As Long
  Dim rngResult As Range
  Dim lngWrite As Long
  Dim strProm As String

  Application.ScreenUpdating = False
  
  '「とらん」データシートのA1を基準とします
  Set rngList1 = Worksheets("とらん").Cells(1, "A")
  '「ますた」データシートのA1を基準とする
  Set rngList2 = Worksheets("ますた").Cells(1, "A")
  '出力シートの基準位置を設定
  Set rngResult = Worksheets("Sheet3").Cells(1, "A")
  
  '「とらん」の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys1 = Array(0, 1)
  '「ますた」の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys2 = Array(0, 1)
  
  '「とらん」の比較データを保持する配列を確保
  ReDim vntList1(0 To UBound(vntKeys1))
  '「ますた」の比較データを保持する配列を確保
  ReDim vntList2(0 To UBound(vntKeys1))
  
  If Not GetBasicData(rngList1, lngRows1, _
        clngColumns1, vntKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  If Not GetBasicData(rngList2, lngRows2, _
        clngColumns2, vntKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  '列見出しをSheet3にCopy
  With rngResult
    .Parent.Cells.Clear
    .Value = "Sheet"
    rngList1.Resize(, clngColumns1).Copy Destination:=.Offset(, 1)
  End With
  
  '「とらん」のシートの比較位置
  lngComp1 = 1
  '「ますた」のシートの比較位置
  lngComp2 = 1
  '「とらん」若しくは、「ますた」が最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '各列のデータを比較
    lngMatch = KeyCompare(vntList1, lngComp1, vntList2, lngComp2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        '「とらん」のデータを取得
        vntData1 = rngList1.Offset(lngComp1) _
                .Resize(, clngColumns1).Value
        '「ますた」のデータを取得
        vntData2 = rngList2.Offset(lngComp2) _
                .Resize(, clngColumns2).Value
        With rngResult
          '出力行位置を更新
          lngWrite = lngWrite + 1
          '「Sheet」をSheet3に出力
          .Offset(lngWrite).Value = 1
          '「とらん」のデータをSheet3に出力
          .Offset(lngWrite, 1).Resize(, _
                clngColumns1).Value = vntData1
          '出力行位置を更新
          lngWrite = lngWrite + 1
          '「Sheet」をSheet3に出力
          .Offset(lngWrite).Value = 2
          '「ますた」のデータをSheet3に出力
          .Offset(lngWrite, 1).Resize(, _
                clngColumns2).Value = vntData2
          'データの比較
          For i = 4 To clngColumns1
            'UnMatchなら
            If vntData1(1, i) <> vntData2(1, i) Then
              .Offset(lngWrite - 1, i) _
                  .Resize(2).Interior.Color = vbRed
            End If
          Next i
        End With
        '「とらん」のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        '「ますた」のシートの比較位置を更新
        Do
          lngComp2 = lngComp2 + 1
        Loop Until KeyCompare(vntList1, lngComp1 - 1, _
                    vntList2, lngComp2) <> 0
      Case Is = -1 '「とらん」の固有値の場合
        '「とらん」のデータを取得
        vntData1 = rngList1.Offset(lngComp1) _
                .Resize(, clngColumns1).Value
        With rngResult
          '出力行位置を更新
          lngWrite = lngWrite + 1
          '「Sheet」をSheet3に出力
          .Offset(lngWrite).Value = 1
          '「とらん」のデータをSheet3に出力
          .Offset(lngWrite, 1).Resize(, _
                clngColumns1).Value = vntData1
          '出力行位置を更新
          lngWrite = lngWrite + 1
          '「Sheet」をSheet3に出力
          .Offset(lngWrite).Value = 2
          '出力配列を確保
          ReDim vntData2(1 To 2)
          '「記号」列が"A"で有れば
          If Trim(vntData1(1, clngSymbol + 1)) = cstrMarkA Then
            For i = 1 To 2
              vntData2(i) = "*"
            Next i
            '出力配列をSheet3に出力
            With .Offset(lngWrite, 1).Resize(, 2)
              .Value = vntData2
              .Interior.Color = vbRed
            End With
          ElseIf Trim(vntData1(1, clngSymbol + 1)) = cstrMarkU Then
            For i = 1 To 2
              vntData2(i) = "-"
            Next i
            '出力配列をSheet3に出力
            .Offset(lngWrite, 1).Resize(, 2).Value = vntData2
          End If
        End With
        '「とらん」のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 '「ますた」の固有値の場合
        '「ますた」のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  '「とらん」のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  '「ますた」のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

  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, _
                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 KeyCompare(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
    KeyCompare = 1
    Exit Function
  End If
  If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
    KeyCompare = -1
    Exit Function
  End If    
  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
  If i > lngMax Then
    '戻り値の値として、「等しい」を返す
    KeyCompare = 0
  Else
    'vntKeys1の値が、vntKeys2の値因り小さい場合
    If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
      '戻り値の値として、「小さい」を返す
      KeyCompare = -1
    Else
      '戻り値の値として、「大きい」を返す
      KeyCompare = 1
    End If
  End If
  
End Function

【44288】Re:シートの比較、ご教授下さい。(再記...
発言  ichinose  - 06/11/12(日) 8:21 -

引用なし
パスワード
   おはようございます。


以下のように変更してください。

Sub 実行()
  Dim sh1rng As Range
  Dim sh2rng As Range
  Dim addA As String
  Dim addB As String
  Dim sh2strw As Long
  Dim idx As Long, jdx As Long
'            ↑変数の追加
  Dim rw As Variant
  Dim nsign As String
  '↓本文
  With Worksheets("sheet1")
    Set sh1rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
    End With
  If sh1rng.Row > 1 Then
    With Worksheets("sheet2")
     Set sh2rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
     sh2strw = sh2rng.Row
     If sh2strw > 1 Then
       addA = sh2rng.Address(, , , True)
       addB = sh2rng.Offset(0, 1).Address(, , , True)
       End If
     End With
    For idx = 1 To sh1rng.Count
     rw = CVErr(xlErrNA)
     If sh2strw > 1 Then
       rw = Evaluate("=match(1,(" & addA & "=" & sh1rng.Cells(idx) & _
             ")*(" & addB & "=" & sh1rng.Offset(0, 1).Cells(idx) & _
             "),0)")
       '↑検索
       End If
     With Worksheets("sheet3")
       .Cells(idx * 2, 1).Value = 1
       .Range(.Cells(idx * 2, 2), .Cells(idx * 2, 12)).Value = sh1rng(idx).Resize(, 11).Value
       .Cells(idx * 2 + 1, 1).Value = 2
       If IsError(rw) Then
        Select Case sh1rng(idx, 3).Value
         Case "D":
            nsign = "-"
         Case Else:
            nsign = "*"
            .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
        End Select
        .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Value = nsign
       Else
        .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 12)).Value = sh2rng(rw).Resize(, 11).Value
        Select Case sh1rng(idx, 3).Value
          Case "A", "U":
            For jdx = 5 To 12
             If .Cells(idx * 2, jdx).Value <> .Cells(idx * 2 + 1, jdx).Value Then
               .Cells(idx * 2 + 1, jdx).Interior.ColorIndex = 3
               End If
             Next jdx
         Case Else:
'           記号がDのときは、各項目比較は要らないのですか?
          .Range(.Cells(idx * 2 + 1, 2), .Cells(idx * 2 + 1, 3)).Interior.ColorIndex = 3
        End Select
       End If
       End With
     Next
    End If
End Sub

プログラムって数学の数列のように規則性を見出せば、
ループ処理が使えますからね!!
(複雑なものはこれが発見できるか否かがキーポイントになります)

取り合えず、Sheet1のデータがSheet2に存在した場合、
しかも記号が A 又は、U の場合、

Sheet1とSheet2の項目1から項目8を比較
して一致しないセルのマスタ側のセルを赤く塗りつぶす
処理は出来ています。

試してみてください。

【44295】Re:シートの比較、ご教授下さい。(再記...
お礼  ドルフィン  - 06/11/12(日) 11:52 -

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

hirofumi様

さっそくのご返答ありがとうございます。
実行した結果、思った結果を得られました。

まことにありがとうございました。

【44296】Re:シートの比較、ご教授下さい。(再記...
お礼  ドルフィン  - 06/11/12(日) 12:08 -

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

ichinose様

こんにちは。
vba初心者のドルフィンです。

さっそくのご解答ありがとうございます。
実行した結果、思う通りに処理が動きました。

【質問の解答】
>'記号がDのときは、各項目比較は要らないのですか?
⇒項目比較は必要ありませんです。

ループ処理、大変勉強になります。
ありがとうございました。
それでは失礼致します。

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