Advertisement
nwaughachukwuma

Untitled

Feb 25th, 2017
134
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 3.36 KB | None | 0 0
  1. Sub sbHighlightDuplicatesInColumn()
  2. Dim lastRow As Long
  3. Dim matchFoundIndex As Long
  4. Dim iCntr As Long
  5.  
  6. lastRow = Sheets("Sheet1").Range("A1").SpecialCells(xlCellTypeLastCell).Row
  7. For iCntr = 1 To lastRow
  8. If Cells(iCntr, 1) <> "" Then
  9. matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range(Cells(1, 1), Cells(iCntr, 1)), 0)
  10. If iCntr <> matchFoundIndex Then
  11. Sheets("Sheet1").Cells(iCntr, 1).Interior.Color = vbYellow
  12. End If
  13. End If
  14. Next
  15.  
  16. 'iterating over the 2 columns...
  17.  
  18. numOfRows = ActiveWorkbook.Worksheets("Sheet1").Range("A2", Worksheets("Sheet1").Range("A2").End(xlDown)).Rows.Count
  19. freq = numOfRows / 12
  20.  
  21. Dim lastRowL As Long
  22. lastRowL = Sheets("Sheet1").Range("L1").SpecialCells(xlCellTypeLastCell).Row
  23.  
  24. Dim LastRowM As Long
  25. LastRowM = Sheets("Sheet1").Range("M1").SpecialCells(xlCellTypeLastCell).Row
  26.  
  27. Dim rg1 As Range, rg2 As Range
  28. Set rg1 = ActiveWorkbook.Worksheets("Sheet1").Range("A2:A4")
  29. Set rg2 = ActiveWorkbook.Worksheets("Sheet1").Range("G2:G4")
  30.  
  31. ' Create dynamic array
  32. Dim tmpArray1 As Variant, tempArray2 As Variant
  33. Dim code As Variant, value As Variant
  34.  
  35. 'Dump the range into a 2D array
  36. tmpArray1 = rg1.value
  37. tmpArray2 = rg2.value
  38.  
  39. 'Resize the 1D array
  40. ReDim code(1 To UBound(tmpArray1, 1))
  41. ReDim value(1 To UBound(tmpArray2, 1))
  42.  
  43. 'Convert 2D to 1D
  44. For i = 1 To UBound(code, 1)
  45. code(i) = tmpArray1(i, 1)
  46. value(i) = tmpArray2(i, 1)
  47. Next
  48.  
  49. For cnt = 1 To freq
  50. 'iterate over col-L
  51. Dim u As Integer, v As Integer
  52. u = cnt * 3 + 2
  53. v = u + 2
  54.  
  55. Dim iTrack As Integer
  56. iTrack = 1
  57. 'iterate over col-L
  58. For iCntr = u To v
  59. If Cells(iCntr, 8) <> "" Then
  60. matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 8), Range(Cells(1, 8), Cells(iCntr, 8)), 0)
  61. If code(iTrack) <> matchFoundIndex Then
  62. Sheets("Sheet1").Cells(iCntr, 8).Interior.Color = vbYellow
  63. Else
  64. Sheets("Sheet1").Cells(iCntr, 8).Interior.Color = vbGreen
  65. End If
  66. End If
  67. iTrack = iTrack + 1
  68. Next
  69.  
  70. iTrack = 1
  71. 'iterate over col-M
  72. For iCntr = u To v
  73. If Cells(iCntr, 9) <> "" Then
  74. matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 9), Range(Cells(1, 9), Cells(iCntr, 9)), 0)
  75. If value(iTrack) <> matchFoundIndex Then
  76. Sheets("Sheet1").Cells(iCntr, 9).Interior.Color = vbRed
  77. Else
  78. Sheets("Sheet1").Cells(iCntr, 9).Interior.Color = vbGreen
  79. End If
  80. End If
  81. iTrack = iTrack + 1
  82. Next
  83. Next
  84.  
  85. End Sub
  86. Private Sub Worksheet_Change(ByVal Target As Range)
  87.  
  88. Dim curColor As Variant
  89. curColor = ActiveCell.Interior.Color
  90. If Application.CountIf(Range("A:A"), Target) > 1 Then
  91. MsgBox "Duplicate Data", vbCritical, "Remove Data"
  92. Target.value = ""
  93. 'ActiveCell.Offset(RowOffset:=-1).EntireRow.Interior.Color = curColor
  94. End If
  95. End Sub
  96.  
  97. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  98.  
  99. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement