NM123
07-16-2012, 02:04 AM
HI All,
I am trying two compare to version of excel sheet. I would like track the changes happened from preivous release to current verison and I would like to add new Column called "Change Flag" which will show the
belwo values:
1. Added
2.Modified
3.Deleted
4.No Change.
The changes will be highlighted in a specfic Text i.e. New Value and Old Value with the date of 2 version of sheet.
I have attached the code for your reference along with the Sample version of 2 excel sheet. Please have a look.
Attribute VB_Name = "Module11"
Sub test()
Dim a, i As Long, ii As Long, w(), temp, flg As Boolean
On Error GoTo ERRORLABEL
With Workbooks.Open(ThisWorkbook.Path & "\ITC SM- Requirements Report_04-16-2012.xls")
a = .Sheets(1).Range("a1").CurrentRegion.Value
Application.DisplayAlerts = False
.Sheets(1).Range("a1").CurrentRegion.Copy
Sheet3.Range("A1").PasteSpecial xlPasteAll
.Close False
Application.DisplayAlerts = True
End With
ReDim w(1 To UBound(a, 2))
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
For ii = 1 To UBound(a, 2)
w(ii) = a(i, ii)
Next
.Item(a(i, 1)) = w
Next
a = ThisWorkbook.Sheets(1).Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If .exists(a(i, 1)) Then
w = .Item(a(i, 1))
For ii = 2 To UBound(a, 2)
If w(ii) <> a(i, ii) Then
temp = a(i, ii): a(i, ii) = ""
a(i, ii) = "OLD - 04-16-2012 : " & w(ii) & vbLf & _
"NEW - 06-15-2012 : " & temp
flg = True
End If
Next
If Not flg Then
a(i, 1) = ""
End If
End If
flg = False '<----
Next
End With
With ThisWorkbook.Sheets(2)
With .Range("a1").Resize(UBound(a, 1), UBound(a, 2))
.Value = a
On Error Resume Next
.Columns(1).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
End With
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set Rng = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
strHL = Array("NEW - 06-15-2012 : ", "OLD - 04-16-2012 : ")
For j = LBound(strHL) To UBound(strHL)
For Each cll In Rng
If InStr(cll, strHL(j)) <> 0 Then
SelStart = InStr(cll, strHL(j))
cll.Characters(SelStart, 18).Font.Color = vbRed
Sheet2.Range("S" & cll.Row).Value = "Modified"
End If
Next cll
Next j
End With
Call LookForDiscrepancies
Exit Sub
ERRORLABEL:
MsgBox "Error occured while executing function" & Chr(13) & "Error Type -> " & Err.Description & Chr(13) & "Contact Technical Team", vbCritical, "Error Number -> " & Err.Number
End Sub
Sub LookForDiscrepancies()
'-------------------------------------------------------------------------------------------------------------------------
'Description - This function will mark the comparison status with Added or Deleted
'Created By - Abhishek (AP80010664)
'Created On - 06/18/2012
'Updated On - 07/05/2012
'Remark - NA
'-------------------------------------------------------------------------------------------------------------------------
Dim rngS2 As Range
Dim rngS3 As Range
Dim c As Range
Dim c1 As Range
Dim c2 As Range
Dim i As Integer
Dim lngRow As Long
Dim lngLastRow As Long
Sheet1.Select
Set rngS2 = Sheet2.Range("A2:A9000")
Sheet2.Activate
Set rngS3 = Sheet3.Range("A2:A9000")
'Search for Sheet1 IDs on Sheet2
Let i = i + 2
With rngS3
For Each c1 In rngS2
On Error GoTo 0
Set c = .Find(What:=c1.Value)
If c Is Nothing Then
Sheet2.Range("S" & c1.Row).Value = "Added"
Let i = i + 1
End If
Next
End With
Sheet2.Select
'Search for Sheet2 IDs on Sheet1
Let i = i + 2
With rngS2
For Each c2 In rngS3
On Error GoTo 0
Set c = .Find(What:=c2.Value)
If c Is Nothing Then
With Sheet3.Range("S" & c2.Row)
.Value = "Deleted"
c2.EntireRow.Copy
End With
Sheet2.Select
lngLastRow = Application.WorksheetFunction.CountA(Sheet2.Range("A1:A6000")) + 1
Sheet2.Range("A" & lngLastRow).PasteSpecial xlPasteAll
Let i = i + 1
End If
Next
End With
Sheet2.Range("S2:S" & lngLastRow).Replace What:="", Replacement:="No Change", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False
Sheet2.Range("S1").Value = "Change Flag"
End Sub
Thanking you,
NM
I am trying two compare to version of excel sheet. I would like track the changes happened from preivous release to current verison and I would like to add new Column called "Change Flag" which will show the
belwo values:
1. Added
2.Modified
3.Deleted
4.No Change.
The changes will be highlighted in a specfic Text i.e. New Value and Old Value with the date of 2 version of sheet.
I have attached the code for your reference along with the Sample version of 2 excel sheet. Please have a look.
Attribute VB_Name = "Module11"
Sub test()
Dim a, i As Long, ii As Long, w(), temp, flg As Boolean
On Error GoTo ERRORLABEL
With Workbooks.Open(ThisWorkbook.Path & "\ITC SM- Requirements Report_04-16-2012.xls")
a = .Sheets(1).Range("a1").CurrentRegion.Value
Application.DisplayAlerts = False
.Sheets(1).Range("a1").CurrentRegion.Copy
Sheet3.Range("A1").PasteSpecial xlPasteAll
.Close False
Application.DisplayAlerts = True
End With
ReDim w(1 To UBound(a, 2))
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
For ii = 1 To UBound(a, 2)
w(ii) = a(i, ii)
Next
.Item(a(i, 1)) = w
Next
a = ThisWorkbook.Sheets(1).Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If .exists(a(i, 1)) Then
w = .Item(a(i, 1))
For ii = 2 To UBound(a, 2)
If w(ii) <> a(i, ii) Then
temp = a(i, ii): a(i, ii) = ""
a(i, ii) = "OLD - 04-16-2012 : " & w(ii) & vbLf & _
"NEW - 06-15-2012 : " & temp
flg = True
End If
Next
If Not flg Then
a(i, 1) = ""
End If
End If
flg = False '<----
Next
End With
With ThisWorkbook.Sheets(2)
With .Range("a1").Resize(UBound(a, 1), UBound(a, 2))
.Value = a
On Error Resume Next
.Columns(1).SpecialCells(4).EntireRow.Delete
On Error GoTo 0
End With
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set Rng = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
strHL = Array("NEW - 06-15-2012 : ", "OLD - 04-16-2012 : ")
For j = LBound(strHL) To UBound(strHL)
For Each cll In Rng
If InStr(cll, strHL(j)) <> 0 Then
SelStart = InStr(cll, strHL(j))
cll.Characters(SelStart, 18).Font.Color = vbRed
Sheet2.Range("S" & cll.Row).Value = "Modified"
End If
Next cll
Next j
End With
Call LookForDiscrepancies
Exit Sub
ERRORLABEL:
MsgBox "Error occured while executing function" & Chr(13) & "Error Type -> " & Err.Description & Chr(13) & "Contact Technical Team", vbCritical, "Error Number -> " & Err.Number
End Sub
Sub LookForDiscrepancies()
'-------------------------------------------------------------------------------------------------------------------------
'Description - This function will mark the comparison status with Added or Deleted
'Created By - Abhishek (AP80010664)
'Created On - 06/18/2012
'Updated On - 07/05/2012
'Remark - NA
'-------------------------------------------------------------------------------------------------------------------------
Dim rngS2 As Range
Dim rngS3 As Range
Dim c As Range
Dim c1 As Range
Dim c2 As Range
Dim i As Integer
Dim lngRow As Long
Dim lngLastRow As Long
Sheet1.Select
Set rngS2 = Sheet2.Range("A2:A9000")
Sheet2.Activate
Set rngS3 = Sheet3.Range("A2:A9000")
'Search for Sheet1 IDs on Sheet2
Let i = i + 2
With rngS3
For Each c1 In rngS2
On Error GoTo 0
Set c = .Find(What:=c1.Value)
If c Is Nothing Then
Sheet2.Range("S" & c1.Row).Value = "Added"
Let i = i + 1
End If
Next
End With
Sheet2.Select
'Search for Sheet2 IDs on Sheet1
Let i = i + 2
With rngS2
For Each c2 In rngS3
On Error GoTo 0
Set c = .Find(What:=c2.Value)
If c Is Nothing Then
With Sheet3.Range("S" & c2.Row)
.Value = "Deleted"
c2.EntireRow.Copy
End With
Sheet2.Select
lngLastRow = Application.WorksheetFunction.CountA(Sheet2.Range("A1:A6000")) + 1
Sheet2.Range("A" & lngLastRow).PasteSpecial xlPasteAll
Let i = i + 1
End If
Next
End With
Sheet2.Range("S2:S" & lngLastRow).Replace What:="", Replacement:="No Change", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False
Sheet2.Range("S1").Value = "Change Flag"
End Sub
Thanking you,
NM