Code for alternative(2) output
In support of this post:
http://www.excelfox.com/forum/showth...0764#post10764
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"))
Call Out2Testies(Worksheets("Original"), Worksheets("NEW"))
End Sub
Sub Out2Testies(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 arrOut(1 To UBound(arrSht2(), 1), 1 To 1) ' arrOut() is now only one column, as I am using the concatenated string in the output
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) = arrSht2Chk(Cnt)
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 " & arrSht2ChkKopie(MtchRes)
Else
Let arrOut(MtchRes, 1) = ""
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: " & arrSht1Chk(Cnt)
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
If arrOut(Cnt, 1) <> "" Then '
Let arrOut(Cnt, 1) = arrSht1Chk(Cnt) & " < > " & arrOut(Cnt, 1)
Else
End If
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").Value = "Test Output": Ws3.Range("H1:M1").Value = "NEW"
Let Ws3.Range("A2").Resize(UBound(arrSht1(), 1), UBound(arrSht1(), 2)).Value = arrSht1()
Let Ws3.Range("G2").Resize(UBound(arrOut(), 1), 1).Value = arrOut()
Let Ws3.Range("H2").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
