Code:
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
Reply With Quote
Bookmarks