Сравните данные из 2-х листов и найдите несоответствия

Question

У меня 3 листа в моей книге, 2 из них содержат аналогичную информацию - одни и те же столбцы, но данные могут отличаться.

Итак, в колонке A есть список единиц, затем в колонке B есть содержимое, в столбце C - температура, а в столбце D - пункт назначения.

То, что я пытаюсь сделать, - сравнить данные из 2-х листов, чтобы показать все несоответствия в Листе 3 - то есть, если число единиц (A) соответствует, искать несоответствия в содержании (B), температуре (c) и пункт назначения (D). Если какой-либо из этих данных отличается, скопируйте его бок о бок с двух листов на третий.

Затем сравните номера единиц - если число найдено на одном листе, но не в другом, выделите его красным цветом, если совпадают номера из обоих списков, выделите их желтым цветом или оставите цвет одинаковым.

Это то, что я получил до сих пор:

Option Explicit 

Const MySheet1 As String = "Sheet1" 'list 1 

Const MySheet2 As String = "Sheet2" 'list 2 

Const MySheet3 As String = "Sheet3" 'output sheet 

Sub CompareLists() 

    Dim List1() As Variant, List2() As Variant 
    Dim LC1 As Long, LC2 As Long, ORow As Long 
    Dim Loop1 As Long, Loop2 As Long, Loop3 As Long 

    ORow = 4 
    With ThisWorkbook 
     LC1 = .Sheets(MySheet1).UsedRange.Rows.Count 
     LC2 = .Sheets(MySheet2).UsedRange.Rows.Count 
     List1 = .Sheets(MySheet1).Range("A1:D" & LC1).Value 
     List2 = .Sheets(MySheet2).Range("A1:D" & LC2).Value 

For Loop2 = 2 To LC2 

    If Len(List2(Loop2, 3)) > 0 Then 
     List2(Loop2, 3) = Trim(List2(Loop2, 3)) 
    End If 

Next Loop2 

     With .Sheets(MySheet3) 
      .Cells.ClearContents 
      .Range("A1").Value = "Mismatched Records" 
      .Range("A3").Value = "Unit Number" 
      .Range("B2").Value = MySheet1 
      .Range("E2").Value = MySheet2 
      .Range("B3").Value = "Type" 
      .Range("C3").Value = "Required Temperature" 
      .Range("D3").Value = "Final Destination" 
      .Range("E3").Value = "Type" 
      .Range("F3").Value = "Required Temperature" 
      .Range("G3").Value = "Final Destination" 
     End With 
     For Loop1 = 2 To LC1 
      For Loop2 = 2 To LC2 
       If Trim(List1(Loop1, 1)) = Trim(List2(Loop2, 1)) Then 
        For Loop3 = 2 To 4 
         If Trim(List1(Loop1, Loop3)) <> Trim(List2(Loop2, Loop3)) Then 
          With .Sheets(MySheet3) 
           .Range("A" & ORow).Value = List1(Loop1, 1) 
           .Range("B" & ORow).Value = List1(Loop1, 2) 
           .Range("C" & ORow).Value = List1(Loop1, 3) 
           .Range("D" & ORow).Value = List1(Loop1, 4) 
           .Range("E" & ORow).Value = List2(Loop2, 2) 
           .Range("F" & ORow).Value = List2(Loop2, 3) 
           .Range("G" & ORow).Value = List2(Loop2, 4) 
          End With 
          ORow = ORow + 1 
          Exit For 
         End If 
        Next Loop3 
        Exit For 
       Else 
        DoEvents 
       End If 
      Next Loop2 
     Next Loop1 
    End With 

    MsgBox "Finished", vbInformation, "Done!" 

End Sub 

Но код не работает должным образом - то есть это не список существующих несовпадений на выходном листе, а также не выделяет блок несовпадающих цифры в красном.

Answer 1

Проблема, которую я вижу, заключается в том, что сравнение данных основывается на сопоставлении ключевых столбцов. Если в столбце A Sheet1 нет значения, которое не существует в столбце A Sheet2, остальные значения из столбца B каждой таблицы не проверяются, и ничего не сообщается. При разумном использовании Exit ForFor Each...Next Statement, который сравнивает ключевой столбец, никогда не должен доходить до его завершения. Если это так, то есть что-то в столбце Sheet1, который не существует в столбце A Sheet2, и это должно быть сообщено.

Option Explicit 

Const MySheet1 As String = "Sheet1" 'list 1 
Const MySheet2 As String = "Sheet2" 'list 2 
Const MySheet3 As String = "Sheet3" 'output sheet 

Sub CompareLists2() 

    Dim List1 As Variant, List2 As Variant 
    Dim LC1 As Long, LC2 As Long, ORow As Long 
    Dim Loop1 As Long, Loop2 As Long, Loop3 As Long 

    ORow = 4 
    With ThisWorkbook 
     LC1 = .Sheets(MySheet1).UsedRange.Rows.Count 
     LC2 = .Sheets(MySheet2).UsedRange.Rows.Count 
     List1 = .Sheets(MySheet1).Range("A1:D" & LC1).Value 
     List2 = .Sheets(MySheet2).Range("A1:D" & LC2).Value 

     For Loop2 = 2 To LC2 
      List2(Loop2, 3) = Trim(List2(Loop2, 3)) 
     Next Loop2 

     With .Sheets(MySheet3) 
      .Cells.ClearContents 
      .Range("A1").Value = "Mismatched Records" 
      .Range("A3").Value = "Unit Number" 
      .Range("B2").Value = MySheet1 
      .Range("E2").Value = MySheet2 
      .Range("B3").Value = "Type" 
      .Range("C3").Value = "Required Temperature" 
      .Range("D3").Value = "Final Destination" 
      .Range("E3").Value = "Type" 
      .Range("F3").Value = "Required Temperature" 
      .Range("G3").Value = "Final Destination" 
     End With 

     For Loop1 = 2 To LC1 
      For Loop2 = 2 To LC2 
       If Trim(List1(Loop1, 1)) = Trim(List2(Loop2, 1)) Then 
        For Loop3 = 2 To 4 
         If Trim(List1(Loop1, Loop3)) <> Trim(List2(Loop2, Loop3)) Then 
          With .Sheets(MySheet3) 
           .Range("A" & ORow).Value = List1(Loop1, 1) 
           .Range("B" & ORow).Value = List1(Loop1, 2) 
           .Range("C" & ORow).Value = List1(Loop1, 3) 
           .Range("D" & ORow).Value = List1(Loop1, 4) 
           .Range("E" & ORow).Value = List2(Loop2, 2) 
           .Range("F" & ORow).Value = List2(Loop2, 3) 
           .Range("G" & ORow).Value = List2(Loop2, 4) 
          End With 
          ORow = ORow + 1 
          Exit For 
         End If 
        Next Loop3 
        Exit For 
       ElseIf Loop2 = LC2 Then 
        'last loop and no match 
        'this reports sheet1 missing from sheet2 
        With .Sheets(MySheet3) 
         .Range("A" & ORow).Value = List1(Loop1, 1) 
         .Range("B" & ORow).Value = List1(Loop1, 2) 
         .Range("C" & ORow).Value = List1(Loop1, 3) 
         .Range("D" & ORow).Value = List1(Loop1, 4) 
        End With 
        ORow = ORow + 1 
       End If 
      Next Loop2 
     Next Loop1 

     'add a reverse loop for Sheet2 column A keys missing from Sheet1's column A 
     For Loop2 = 2 To UBound(List2, 1) 
      For Loop1 = 2 To UBound(List1, 1) 
       If Trim(List1(Loop1, 1)) = Trim(List2(Loop2, 1)) Then 
        Exit For 
       ElseIf Loop1 = UBound(List1, 1) Then 
        'last loop and no match 
        'this reports sheet2 missing from sheet1 
        With .Sheets(MySheet3) 
         .Range("A" & ORow).Value = List2(Loop2, 1) 
         .Range("E" & ORow).Value = List2(Loop2, 2) 
         .Range("F" & ORow).Value = List2(Loop2, 3) 
         .Range("G" & ORow).Value = List2(Loop2, 4) 
        End With 
        ORow = ORow + 1 
       End If 
      Next Loop1 
     Next Loop2 

    End With 

    MsgBox "Finished", vbInformation, "Done!" 

End Sub 

Я добавил половинную обратную петлю также поймать ключи от столбца A Лист2, что не найдены в столбце A. Лист1 в