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

**DocAElstein** · 07-19-2018, 02:24 PM

Test runs from code

Code:

Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741
' Call Testie(Worksheets("Sheet1"), Worksheets("Sheet2"))
 Call Testy(Worksheets("Sheet1"), Worksheets("Sheet2"))
End Sub

For support of this excelfox Thread:
http://www.excelfox.com/forum/showth...0741#post10741

Using Excel 2007 32 bit

Sheet1	Sheet1	Test Output	Test Output	Sheet2	Sheet2
Customer	Assembly			Customer	Assembly
Nu Torque	13456			Nu Torque	13456
Blu Origin	Spaceship			Blu Origin	Spaceship
Jet Blue21	ABC
Alaska	789
Toyota	Supra
Emirate	ABC12345



				Jet Blue21	ABC
				Alaska	789
				Toyota	Supra
				Emirate	ABC12345
		Dup 2 of Toyota	Dup 2 of Supra	Toyota	Supra
		Dup 2 of Emirate	Dup 2 of ABC12345	Emirate	ABC12345
		Spaceship	12	Spaceship	12

Worksheet: Tabelle3

Using Excel 2007 32 bit

Sheet1	Sheet1	Test Output	Test Output	Sheet2	Sheet2
Customer	Assembly			Customer	Assembly
Nu Torque	13456			Nu Torque	13456
Blu Origin	Spaceship			Alaska	789
Jet Blue21	ABC	Excel123	HiThai	Excel123	HiThai
Alaska	789			Blu Origin	Spaceship
Toyota	Supra			Emirate	ABC12345
Emirate	ABC12345			Jet Blue21	ABC
				Toyota	Supra

Worksheet: Tabelle3

**DocAElstein** · 07-19-2018, 02:40 PM

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

Code:

Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#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
'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)) ' Arrays for concatenated data
'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
'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)
    '3a 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 ' ----------------------------------------
     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 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

**DocAElstein** · 07-23-2018, 03:57 PM

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

Code:

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

**DocAElstein** · 07-23-2018, 04:03 PM

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

Using Excel 2007 32 bit

_Row\^Col	A	B	C	D	E	F
1	Sheet1	Sheet1	Test Output	Test Output	Sheet2	Sheet2
2	Customer	Assembly			Customer	Assembly
3	Nu Torque	13456			Nu Torque	13456
4	Blu Origin	Spaceship			Alaska	789
5	Jet Blue21	ABC	Excel123	HiThai	Excel123	HiThai
6	Alaska	789			Blu Origin	Spaceship
7	Toyota	Supra	Missing: Toyota	Missing: Supra	Emirate	ABC12345
8	Emirate	ABC12345			Jet Blue21	ABC
9

Worksheet: Tabelle3

**DocAElstein** · 07-26-2018, 02:33 PM

Results in support of answer to this post
http://www.excelfox.com/forum/showth...0749#post10749
( note a typo in your data for row 9 ( correspondingly output row 10 in these screenshots) : Angle is not Angel . hence this is taken by my code as Missing data row )

Using Excel 2007 32 bit

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	Original	Original	Original	Original	Original	Original	Test Output	Test Output	Test Output	Test Output	Test Output	NEW	NEW	NEW	NEW	NEW	NEW
2			Assembly #:			Assembly Name:					Assembly Name:			Assembly #:			Assembly Name:
3	Qty Per	Ref/Designator	Description	Customer PN	Internal PN	Manufacture PN			Customer PN	Internal PN	Manufacture PN	Qty Per	Ref/Designator	Description	Customer PN	Internal PN	Manufacture PN
4	1	Nu Torque		13456	456	456			13456	456	456	1	Nu Torque		13456	456	456
5	1	Blu Origin		Spaceship	457	457			Spaceship	457	457	1	Blu Origin		Spaceship	457	457
6	2	Jet Blue21		ABC	458	458			ABC	458	458	2	Jet Blue21		ABC	458	458
7	3	EXCELL123		123	ABC	ABC	MISSING: 3	MISSING: EXCELL123	MISSING: 123	MISSING: ABC	MISSING: ABC	3	Alaska		789	459	459
8	3	Toyota		Supra	460	460			Supra	460	460	3	Toyota		Supra	460	460
9	2	Emirate		ABC12345	461	461			ABC12345	461	461	2	Emirate		ABC12345	461	461
10	1	Angel		ABC12346	462	462	MISSING: 1	MISSING: Angel	MISSING: ABC12346	MISSING: 462	MISSING: 462	1	Angle		ABC12346	462	462

Worksheet: Result

Using Excel 2007 32 bit

Original	Original	Original	Original	Original	Original	Test Output	Test Output	Test Output	Test Output	Test Output	NEW	NEW	NEW	NEW	NEW	NEW
		Assembly #:			Assembly Name:					Assembly Name:			Assembly #:			Assembly Name:
Qty Per	Ref/Designator	Description	Customer PN	Internal PN	Manufacture PN			Customer PN	Internal PN	Manufacture PN	Qty Per	Ref/Designator	Description	Customer PN	Internal PN	Manufacture PN
1	Nu Torque		13456	456	456			13456	456	456	1	Nu Torque		13456	456	456
1	Blu Origin		Spaceship	457	457			Spaceship	457	457	1	Blu Origin		Spaceship	457	457
2	Jet Blue21		ABC	458	458			ABC	458	458	2	Jet Blue21		ABC	458	458
3	EXCELL123		123	ABC	ABC	MISSING: 3	MISSING: EXCELL123	MISSING: 123	MISSING: ABC	MISSING: ABC	3	Alaska		789	459	459
3	Toyota		Supra	460	460			Supra	460	460	3	Toyota		Supra	460	460
2	Emirate		ABC12345	461	461			ABC12345	461	461	2	Emirate		ABC12345	461	461
1	Angel		ABC12346	462	462	MISSING: 1	MISSING: Angel	MISSING: ABC12346	MISSING: 462	MISSING: 462	1	Angle		ABC12346	462	462

Worksheet: Result

**DocAElstein** · 07-26-2018, 02:43 PM

Code corresponding to last post, in support of answer to this post
http://www.excelfox.com/forum/showth...0749#post10749

Code:

Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741
' Call Testie(Worksheets("Original"), Worksheets("NEW"))
' Call Testy(Worksheets("Original"), Worksheets("NEW"))
 Call Testies(Worksheets("Original"), Worksheets("NEW"))
End Sub
Sub Testies(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("B1:G" & Lr1 & "").Value
 Let arrSht2() = Ws2.Range("B1:G" & Lr1 & "").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) - 1) ' -1 as one column , D is not required
 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)
     Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2) & "|" & arrSht1(Cnt, 4) & "|" & arrSht1(Cnt, 5) & "|" & arrSht1(Cnt, 6)
    Next Cnt
    For Cnt = 1 To UBound(arrSht2(), 1) Step 1
'     Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2)
      Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2) & "|" & arrSht2(Cnt, 4) & "|" & arrSht2(Cnt, 5) & "|" & arrSht2(Cnt, 6)
    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 NEW
    For Cnt = 1 To UBound(arrSht2(), 1) Step 1
     Let arrOut(Cnt, 1) = CStr(arrSht2(Cnt, 1)): arrOut(Cnt, 2) = CStr(arrSht2(Cnt, 2)): arrOut(Cnt, 3) = CStr(arrSht2(Cnt, 4)):: arrOut(Cnt, 4) = CStr(arrSht2(Cnt, 5)):: arrOut(Cnt, 5) = CStr(arrSht2(Cnt, 6))
    Next Cnt
Rem 3 main loop   ' == Start Main loop ================
    For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
    Dim MtchRes As Variant
     Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
'        If IsError(MtchRes) Then ' case data is MISSING: NEW ( MISSING: ) ' 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 Original in NEW
'         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 Original
    Next Cnt ' ========= End Main loop ================= effectively we go to next row of data in Original with this line
Rem 3b Second Loop   ' ##### Start Second  loop #####
    For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
    'Dim MtchRes As Variant
     Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2ChkKopie, 0)
        If IsError(MtchRes) Then ' case data is missing NEW ( MISSING: )
         Let arrOut(Cnt, 1) = "MISSING: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "MISSING: " & arrSht1(Cnt, 2): arrOut(Cnt, 3) = "MISSING: " & arrSht1(Cnt, 4): arrOut(Cnt, 4) = "MISSING: " & arrSht1(Cnt, 5): arrOut(Cnt, 5) = "MISSING: " & arrSht1(Cnt, 6)
        Else
        End If '
     Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Original
    Next Cnt ' ##### End Second Loop #################       effectively we go to next row of data in Original 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("Result")
 Ws3.Cells.ClearContents
 Let Ws3.Range("A1:F1").Value = "Original": Ws3.Range("G1:K1").Value = "Test Output": Ws3.Range("L1:Q1").Value = "NEW"
 Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
 Let Ws3.Range("G2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
 Let Ws3.Range("L2").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

**DocAElstein** · 07-29-2018, 11:51 AM

Suggested test data to answer this post: http://www.excelfox.com/forum/showth...0754#post10754

Using Excel 2007 32 bit

_Row\^Col	A	B	C	D	E	F	G
1	Customer:			Assembly #:			Assembly Name:
2	#	Qty Per	Ref/Designator	Description	Customer PN	Internal PN	Manufacture PN
3	1	1	Nu Torque		13456	456	456
4	2	1	Blu Origin		Spaceship	457	457
5	3	2	Jet Blue21		ABC	458	458
6	4	3	EXCELL123		123	ABC	ABC
7	5	3	Toyota		Supra	460	460
8	6	2	Emirate		ABC12345	461	461
9	7	1	Angel		ABC12346	462	462

Worksheet: Original

Using Excel 2007 32 bit

_Row\^Col	A	B	C	D	E	F	G
1	Customer:			Assembly #:			Assembly Name:
2	#	Qty Per	Ref/Designator	Description	Customer PN	Internal PN	Manufacture PN
3	1	1	Nu Torque		13456	456	456
4	2	1	Blu Origin		Spaceship	457	457
5	3	2	Jet Blue23		ABC	DEF	DEF
6	4	3	EXCELL123		123	ABC	ABC
7	5	3	Toyota		Supra	460	460
8	6	2	Emirate		ABC12345	461	461
9	3	2	Jet Blue21		ABC	458	458

Worksheet: NEW

**DocAElstein** · 07-29-2018, 12:00 PM

In the last code , ( Sub Testies ), the following output is obtained when using the suggested test data above ( http://www.excelfox.com/forum/showth...0756#post10756 ) :

Using Excel 2007 32 bit

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	Original	Original	Original	Original	Original	Original	Test Output	Test Output	Test Output	Test Output	Test Output	NEW	NEW	NEW	NEW	NEW	NEW
2			Assembly #:			Assembly Name:								Assembly #:			Assembly Name:
3	Qty Per	Ref/Designator	Description	Customer PN	Internal PN	Manufacture PN						Qty Per	Ref/Designator	Description	Customer PN	Internal PN	Manufacture PN
4	1	Nu Torque		13456	456	456						1	Nu Torque		13456	456	456
5	1	Blu Origin		Spaceship	457	457						1	Blu Origin		Spaceship	457	457
6	2	Jet Blue21		ABC	458	458	2	Jet Blue23	ABC	DEF	DEF	2	Jet Blue23		ABC	DEF	DEF
7	3	EXCELL123		123	ABC	ABC						3	EXCELL123		123	ABC	ABC
8	3	Toyota		Supra	460	460						3	Toyota		Supra	460	460
9	2	Emirate		ABC12345	461	461						2	Emirate		ABC12345	461	461
10	1	Angel		ABC12346	462	462	MISSING: 1	MISSING: Angel	MISSING: ABC12346	MISSING: 462	MISSING: 462	2	Jet Blue21		ABC	458	458

Worksheet: Result

Using Excel 2007 32 bit

_Row\^Col	G	H	I	J	K
1	Test Output	Test Output	Test Output	Test Output	Test Output
2
3
4
5
6	2	Jet Blue23	ABC	DEF	DEF
7
8
9
10	MISSING: 1	MISSING: Angel	MISSING: ABC12346	MISSING: 462	MISSING: 462

Worksheet: Result

Using Excel 2007 32 bit

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	Original	Original	Original	Original	Original	Original	Test Output	Test Output	Test Output	Test Output	Test Output	NEW	NEW	NEW	NEW	NEW	NEW
6	2	Jet Blue21		ABC	458	458	2	Jet Blue23	ABC	DEF	DEF	2	Jet Blue23		ABC	DEF	DEF

Worksheet: Result

_._____________________________________-

We have currently output like this:

Test Output	Test Output	Test Output	Test Output	Test Output
2	Jet Blue23	ABC	DEF	DEF

But We want this to look more similar to screenshot output from post #15 ( http://www.excelfox.com/forum/showth...0754#post10754 )

**DocAElstein** · 07-29-2018, 01:31 PM

Code to answer this post: http://www.excelfox.com/forum/showth...0754#post10754

Code:

Sub TestyCalls() ' http://www.excelfox.com/forum/showthread.php/2277-Vba-button-Comparison-data-between-two-file-or-two-tabs?p=10741#post10741
' Call Testie(Worksheets("Original"), Worksheets("NEW"))
' Call Testy(Worksheets("Original"), Worksheets("NEW"))
' Call Testies(Worksheets("Original"), Worksheets("NEW"))
 Call Tests28July(Worksheets("Original"), Worksheets("NEW"))
End Sub
Sub Tests28July(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("B1:G" & Lr1 & "").Value
 Let arrSht2() = Ws2.Range("B1:G" & Lr1 & "").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) - 1) ' -1 as one column , D is not required
 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)
     Let arrSht1Chk(Cnt) = arrSht1(Cnt, 1) & "|" & arrSht1(Cnt, 2) & "|" & arrSht1(Cnt, 4) & "|" & arrSht1(Cnt, 5) & "|" & arrSht1(Cnt, 6)
    Next Cnt
    For Cnt = 1 To UBound(arrSht2(), 1) Step 1
'     Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2)
      Let arrSht2Chk(Cnt) = arrSht2(Cnt, 1) & "|" & arrSht2(Cnt, 2) & "|" & arrSht2(Cnt, 4) & "|" & arrSht2(Cnt, 5) & "|" & arrSht2(Cnt, 6)
    Next Cnt
 Let arrSht2ChkKopie() = arrSht2Chk() ' Arrays of same size and type can be assiigned to eachother
'2c make contents of array for output initially all dat from NEW
    For Cnt = 1 To UBound(arrSht2(), 1) Step 1
     Let arrOut(Cnt, 1) = CStr(arrSht2(Cnt, 1)): arrOut(Cnt, 2) = CStr(arrSht2(Cnt, 2)): arrOut(Cnt, 3) = CStr(arrSht2(Cnt, 4)):: arrOut(Cnt, 4) = CStr(arrSht2(Cnt, 5)):: arrOut(Cnt, 5) = CStr(arrSht2(Cnt, 6))
    Next Cnt
Rem 3 main loop   ' == Start Main loop ================
    For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
    Dim MtchRes As Variant
     Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2Chk(), 0)
'        If IsError(MtchRes) Then ' case data is MISSING: NEW ( MISSING: ) ' 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 Original in NEW
'         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) = "": arrOut(MtchRes, 3) = "": arrOut(MtchRes, 4) = "": arrOut(MtchRes, 5) = "" ' 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 Original
    Next Cnt ' ========= End Main loop ================= effectively we go to next row of data in Original with this line
Rem 3b Second Loop   ' ##### Start Second  loop #####
    For Cnt = 1 To UBound(arrSht1(), 1) Step 1 ' Counting at each row of NEW
    'Dim MtchRes As Variant
     Let MtchRes = Application.Match(arrSht1Chk(Cnt), arrSht2ChkKopie, 0)
        If IsError(MtchRes) Then ' case data is missing NEW ( MISSING: )
         Let arrOut(Cnt, 1) = "MISSING: " & arrSht1(Cnt, 1): arrOut(Cnt, 2) = "MISSING: " & arrSht1(Cnt, 2): arrOut(Cnt, 3) = "MISSING: " & arrSht1(Cnt, 4): arrOut(Cnt, 4) = "MISSING: " & arrSht1(Cnt, 5): arrOut(Cnt, 5) = "MISSING: " & arrSht1(Cnt, 6)
        Else
        End If '
     Let DupyCnt = 0 ' reset the Duplicated data count for next row of data in Original
    Next Cnt ' ##### End Second Loop #################       effectively we go to next row of data in Original with this line
Rem 3c(i) Third Loop  ' @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    For Cnt = 1 To UBound(arrOut(), 1) Step 1 ' Counting at each row of output arrray
        If InStr(1, arrOut(Cnt, 1), "MISSING:", vbBinaryCompare) <> 1 Then
        Dim Cntx As Long ' for loop across "columns"
        '3c(ii) Loop across columns in output array
            For Cntx = 1 To 2 ' .....we need to break up into two loops, as we have columns in Output array of 1 2 3 4 5 but in Input array for sheet 1 we have B C D E F G .. D is ignored,
                If arrOut(Cnt, Cntx) <> "" And arrOut(Cnt, Cntx) <> CStr(arrSht1(Cnt, Cntx)) Then ' condition for changed data
                 Let arrOut(Cnt, Cntx) = CStr(arrSht1(Cnt, Cntx)) & " < > " & arrOut(Cnt, Cntx)
                Else
                End If
            Next Cntx
            For Cntx = 3 To UBound(arrOut(), 2) ' we need to do break up into two loops......
                If arrOut(Cnt, Cntx) <> "" And arrOut(Cnt, Cntx) <> CStr(arrSht1(Cnt, Cntx + 1)) Then ' condition for changed data
                 Let arrOut(Cnt, Cntx) = CStr(arrSht1(Cnt, Cntx + 1)) & " < > " & arrOut(Cnt, Cntx)
                Else
                End If
            Next Cntx
        Else ' case we have a Missing row, so no action in Third Loop 3c
        End If
    Next Cnt ' @@@@@ End Third Loop  ' @@@@@@@@@@@@@@@@@

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("Result")
 Ws3.Cells.ClearContents
 Let Ws3.Range("A1:F1").Value = "Original": Ws3.Range("G1:K1").Value = "Test Output": Ws3.Range("L1:Q1").Value = "NEW"
 Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
 Let Ws3.Range("G2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
 Let Ws3.Range("L2").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

**DocAElstein** · 07-29-2018, 01:33 PM

Sample test results for code from last post ( http://www.excelfox.com/forum/showth...0758#post10758 )

Using Excel 2007 32 bit

Original

Test Output

NEW

Assembly #:

Assembly Name:

Assembly #:

Assembly Name:

Qty Per

Ref/Designator

Description

Customer PN

Internal PN

Manufacture PN

Qty Per

Ref/Designator

Description

Customer PN

Internal PN

Manufacture PN

1

Nu Torque

13456

456

1

Nu Torque

13456

456

1

Blu Origin

Spaceship

457

1

Blu Origin

Spaceship

457

2

Jet Blue21

ABC

458

2

Jet Blue21 < > Jet Blue23

ABC

458 < > DEF

2

Jet Blue23

ABC

DEF

3

EXCELL123

123

ABC

3

EXCELL123

123

ABC

3

Toyota

Supra

460

3

Toyota

Supra

460

2

Emirate

ABC12345

461

2

Emirate

ABC12345

461

1

Angel

ABC12346

462

MISSING: 1

MISSING: Angel

MISSING: ABC12346

MISSING: 462

2

Jet Blue21

ABC

458

Worksheet: Result

Using Excel 2007 32 bit

Test Output	Test Output	Test Output	Test Output	Test Output




2	Jet Blue21 < > Jet Blue23	ABC	458 < > DEF	458 < > DEF



MISSING: 1	MISSING: Angel	MISSING: ABC12346	MISSING: 462	MISSING: 462