Appendix Thread 2. ( Codes for other Threads, HTML Tables, etc.)

[DocAElstein]

First test code for solution to this thread:
http://www.excelfox.com/forum/showth...le-or-two-tabs

( Run code Sub TestieCalls() )

Option Explicit
Sub TestieCalls()
 Call Testie(Worksheets("Sheet1"), Worksheets("Sheet2"))
End Sub
Sub Testie(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
'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))
'2b 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)
    Next Cnt
Rem 3 main loop   ' == Start main loop ==========
    For Cnt = 1 To UBound(arrSht2(), 1) - 1 Step 1 ' Counting at each row
    Dim DifCnt As Long 'Count of different cells
        ' Condition check
        If (arrSht2(Cnt, 1) <> arrSht1b(Cnt, 1) Or arrSht2(Cnt, 2) <> arrSht1b(Cnt, 2)) And (arrSht2(Cnt + 1, 1) = arrSht1b(Cnt + 1, 1) And arrSht2(Cnt + 1, 2) = arrSht1b(Cnt + 1, 2)) Then  ' condition for changed row but next row is as previous : row had data changed, but a row was not inserted
         Let arrSht1b(Cnt, 1) = arrSht2(Cnt, 1): arrSht1b(Cnt, 2) = arrSht2(Cnt, 2) 'change any changed cell
            If arrSht1b(Cnt, 1) <> arrSht1(Cnt, 1) Then
             Let arrOut(Cnt, 1) = arrSht1b(Cnt, 1) & "  <>  " & arrSht1(Cnt, 1)
             Let DifCnt = DifCnt + 1
            Else: End If
            If arrSht1b(Cnt, 2) <> arrSht1(Cnt, 2) Then
             Let arrOut(Cnt, 2) = arrSht1b(Cnt, 2) & "  <>  " & arrSht1(Cnt, 2)
             Let DifCnt = DifCnt + 1
            Else: End If
        ' Condition check
        ElseIf ((arrSht2(Cnt, 1) <> arrSht1b(Cnt, 1) Or arrSht2(Cnt, 2) <> arrSht1b(Cnt, 2)) And (arrSht2(Cnt + 1, 1) <> arrSht1b(Cnt + 1, 1) Or arrSht2(Cnt + 1, 2) <> arrSht1b(Cnt + 1, 2))) Then   ' main condition suggesting added new row
        Dim AdedRows As Long: Let AdedRows = AdedRows + 1
        '3b we need to shift all data down to allow space for new row in arrSht2()
        Dim CntIn As Long
            For CntIn = (UBound(arrSht2(), 1) - 1) To Cnt Step -1 'loop for all but last from this row
             Let arrSht1b(CntIn + 1, 1) = arrSht1b(CntIn, 1): arrSht1b(CntIn + 1, 2) = arrSht1b(CntIn, 2) ' This effectively pulls up each row by one
            Next CntIn
        '3c add the new data to the modified array, Let arrSht1b()
         Let arrSht1b(Cnt, 1) = arrSht2(Cnt, 1): arrSht1b(Cnt, 2) = arrSht2(Cnt, 2)
            If arrSht1b(Cnt, 1) = "" Then arrSht1b(Cnt, 1) = "           " ' Just to make final output more neat
            If arrSht1b(Cnt, 2) = "" Then arrSht1b(Cnt, 2) = "           "
        '3d add info to the output array
            If Cnt > UBound(arrSht1(), 1) Then ' case of new lines
             Let arrOut(Cnt, 1) = "An new extra line contains  " & arrSht1b(Cnt, 1): arrOut(Cnt, 2) = "An new extra line contains  " & arrSht1b(Cnt, 2)
            
            Else
               If arrSht1b(Cnt, 1) <> arrSht1(Cnt, 1) Then
                Let arrOut(Cnt, 1) = arrSht1b(Cnt, 1) & "  <>  " & arrSht1(Cnt, 1)
                Let DifCnt = DifCnt + 1
               Else: End If
               If arrSht1b(Cnt, 2) <> arrSht1(Cnt, 2) Then
                Let arrOut(Cnt, 2) = arrSht1b(Cnt, 2) & "  <>  " & arrSht1(Cnt, 2)
                Let DifCnt = DifCnt + 1
               Else: End If
            End If
        '
         Let Cnt = Cnt + 1 ' we need to skip the next row as that was just effectively added so we are done with it
        Else ' row has not been added here
         
        End If
    Next Cnt ' ========= End main loop ==========
Rem 4 last row may be new
    If arrSht2(lr2, 1) <> arrSht1(Lr1, 1) Or arrSht2(lr2, 2) <> arrSht1(Lr1, 2) Then ' either cell in last row is different
        If arrSht2(lr2, 1) <> arrSht1(Lr1, 1) Then
         Let arrOut(lr2, 1) = arrSht2(lr2, 1) & "  on last row is new"
         Let DifCnt = DifCnt + 1
        Else: End If
        If arrSht2(lr2, 2) <> arrSht1(Lr1, 2) Then
         Let arrOut(lr2, 2) = arrSht2(lr2, 2) & "  on last row is new"
         Let DifCnt = DifCnt + 1
        Else: End If
    Else 'last row on sheet2 is as on sheet1
    End If
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 MsgBoox output
 MsgBox Prompt:="inserted lines is   " & AdedRows & vbCrLf & "Changed cells is  " & DifCnt
End Sub