Appendix Thread. ( Codes for other Threads, etc.) Event Coding Drpdown Data validation

[DocAElstein]

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

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