Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)

[DocAElstein]

Code in support of this Post
http://www.excelfox.com/forum/showth...0745#post10745

Option Explicit
Sub TestyCalls() ' http://www.excelfox.com/forum/showth...0741#post10741
' Call Testie(Worksheets("Sheet1"), Worksheets("Sheet2"))
 Call Testy(Worksheets("Sheet1"), Worksheets("Sheet2"))
End Sub
Sub Testy(Ws1 As Worksheet, Ws2 As Worksheet)
Rem 1 Worksheet data info
'1a capture data
'1a(i) last data rows
Dim lr1_1 As Long, Lr1_2 As Long, Lr2_1 As Long, Lr2_2 As Long, Lr1 As Long, lr2 As Long
 Let lr1_1 = Ws1.Cells(Rows.Count, 1).End(xlUp).row
 Let Lr1_2 = Ws1.Cells(Rows.Count, 2).End(xlUp).row: Lr2_1 = Ws2.Cells(Rows.Count, 1).End(xlUp).row: Lr2_2 = Ws2.Cells(Rows.Count, 2).End(xlUp).row
    If lr1_1 > Lr1_2 Then
     Let Lr1 = lr1_1
    Else
     Let Lr1 = Lr1_2
    End If
 Let lr2 = Lr2_2: If Lr2_1 > Lr2_2 Then Let lr2 = Lr2_1
'1a(ii) capture data into arrays in one go
Dim arrSht1() As Variant, arrSht2() As Variant
 Let arrSht1() = Ws1.Range("A1:B" & Lr1 & "").Value
 Let arrSht2() = Ws2.Range("A1:B" & lr2 & "").Value
Rem 2 arrays for check and output
Dim arrSht1b() As String, arrOut() As String, arrSht1Chk() As String, arrSht2Chk() As String, arrSht2ChkKopie() As String
'2a size arrays to that of sheet 2 data
' ReDim arrSht1b(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
 ReDim arrOut(1 To UBound(arrSht2(), 1), 1 To UBound(arrSht2(), 2))
 ReDim arrSht1Chk(1 To UBound(arrSht1(), 1))
 ReDim arrSht2Chk(1 To UBound(arrSht2(), 1))
 ReDim arrSht2ChkKopie(1 To UBound(arrSht2(), 1))
'2b make check arrays                                                                                                                                                                       fill modified sheet 1 array, arrSht1b() , initially with sheet 1 data
Dim Cnt As Long
    For Cnt = 1 To UBound(arrSht1(), 1) Step 1
'     Let arrSht1b(Cnt, 1) = arrSht1(Cnt, 1): Let arrSht1b(Cnt, 2) = arrSht1(Cnt, 2)
     Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2)
    Next Cnt
    For Cnt = 1 To UBound(arrSht2(), 1) Step 1
     Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2)
    Next Cnt
 Let arrSht2ChkKopie() = arrSht2Chk() ' Arrays of same size and type can be assiigned too eachother
'2c make contents of array for output initially all dat from Sheet2
    For Cnt = 1 To UBound(arrSht2(), 1) Step 1
     Let arrOut(Cnt, 1) = CStr(arrSht2(Cnt, 1)): arrOut(Cnt, 2) = CStr(arrSht2(Cnt, 2))
    Next Cnt
Rem 3 main loop   ' == Start Main loop ================
    For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of Sheet2
    Dim MtchRes As Variant
     Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
'        If IsError(MtchRes) Then ' case data is missing Sheet2 ( deleted ) ' This straight forward modification to the existing code will not work. This is because the code modifies the check array , arrSht2Chk() , when  checking for the data from sheet1 in sheet2
'         Let arrOut(Cnt, 1) = "Missing: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "Missing: " & arrSht1(Cnt, 2)
'        Else:
        '3a(ii) action whilst match is found --Inner Loop------
            Do While Not IsError(MtchRes) ' The 3a Loop
            Dim DupyCnt As Long: Let DupyCnt = DupyCnt + 1
                If DupyCnt > 1 Then
                 Let arrOut(MtchRes, 1) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 1): arrOut(MtchRes, 2) = "Dup " & DupyCnt & " of " & arrOut(MtchRes, 2)
                Else
                 Let arrOut(MtchRes, 1) = "": arrOut(MtchRes, 2) = "" ' remove the found data from array for output so that next line can look again for a possible duplicate
                End If
                 Let arrSht2Chk(MtchRes) = "" ' remove entry in check array so that next line can look for possible duplicate
             Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
            Loop ' ----------------------------------------
'        End If '
     Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Sheet1
    Next Cnt ' ========= End Main loop ================= effectively we go to next row of data in Sheet1 with this line
Rem 3b Second Loop   ' ##### Start Second  loop #####
    For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of Sheet2
    'Dim MtchRes As Variant
     Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2ChkKopie, 0)
        If IsError(MtchRes) Then ' case data is missing Sheet2 ( deleted )
         Let arrOut(Cnt, 1) = "Missing: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "Missing: " & arrSht1(Cnt, 2)
        Else
        End If '
     Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Sheet1
    Next Cnt ' ##### End Second Loop #################       effectively we go to next row of data in Sheet1 with this line


Rem 5 Output in new file For testing purposes, I give the output in a third worksheet, Tabelle3
Dim Ws3 As Worksheet: Set Ws3 = ThisWorkbook.Worksheets("Tabelle3")
 Ws3.Cells.ClearContents
 Let Ws3.Range("A1:B1").Value = "Sheet1": Ws3.Range("C1:D1").Value = "Test Output": Ws3.Range("E1:F1").Value = "Sheet2"
 Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
 Let Ws3.Range("C2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
 Let Ws3.Range("E2").Resize(UBound(arrSht2(), 1), UBound(arrSht2(), 2)).Value = arrSht2()
 Ws3.Columns.AutoFit
Rem 6 MsgBox output
' MsgBox Prompt:="Inserted lines is   " & AdedRows & vbCrLf & "Changed cells is  " & DifCnt
End Sub