Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Sub sbHighlightDuplicatesInColumn()
- Dim lastRow As Long
- Dim matchFoundIndex As Long
- Dim iCntr As Long
- lastRow = Sheets("Sheet1").Range("A1").SpecialCells(xlCellTypeLastCell).Row
- For iCntr = 1 To lastRow
- If Cells(iCntr, 1) <> "" Then
- matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range(Cells(1, 1), Cells(iCntr, 1)), 0)
- If iCntr <> matchFoundIndex Then
- Sheets("Sheet1").Cells(iCntr, 1).Interior.Color = vbYellow
- End If
- End If
- Next
- 'iterating over the 2 columns...
- numOfRows = ActiveWorkbook.Worksheets("Sheet1").Range("A2", Worksheets("Sheet1").Range("A2").End(xlDown)).Rows.Count
- freq = numOfRows / 12
- Dim lastRowL As Long
- lastRowL = Sheets("Sheet1").Range("L1").SpecialCells(xlCellTypeLastCell).Row
- Dim LastRowM As Long
- LastRowM = Sheets("Sheet1").Range("M1").SpecialCells(xlCellTypeLastCell).Row
- Dim rg1 As Range, rg2 As Range
- Set rg1 = ActiveWorkbook.Worksheets("Sheet1").Range("A2:A4")
- Set rg2 = ActiveWorkbook.Worksheets("Sheet1").Range("G2:G4")
- ' Create dynamic array
- Dim tmpArray1 As Variant, tempArray2 As Variant
- Dim code As Variant, value As Variant
- 'Dump the range into a 2D array
- tmpArray1 = rg1.value
- tmpArray2 = rg2.value
- 'Resize the 1D array
- ReDim code(1 To UBound(tmpArray1, 1))
- ReDim value(1 To UBound(tmpArray2, 1))
- 'Convert 2D to 1D
- For i = 1 To UBound(code, 1)
- code(i) = tmpArray1(i, 1)
- value(i) = tmpArray2(i, 1)
- Next
- For cnt = 1 To freq
- 'iterate over col-L
- Dim u As Integer, v As Integer
- u = cnt * 3 + 2
- v = u + 2
- Dim iTrack As Integer
- iTrack = 1
- 'iterate over col-L
- For iCntr = u To v
- If Cells(iCntr, 8) <> "" Then
- matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 8), Range(Cells(1, 8), Cells(iCntr, 8)), 0)
- If code(iTrack) <> matchFoundIndex Then
- Sheets("Sheet1").Cells(iCntr, 8).Interior.Color = vbYellow
- Else
- Sheets("Sheet1").Cells(iCntr, 8).Interior.Color = vbGreen
- End If
- End If
- iTrack = iTrack + 1
- Next
- iTrack = 1
- 'iterate over col-M
- For iCntr = u To v
- If Cells(iCntr, 9) <> "" Then
- matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 9), Range(Cells(1, 9), Cells(iCntr, 9)), 0)
- If value(iTrack) <> matchFoundIndex Then
- Sheets("Sheet1").Cells(iCntr, 9).Interior.Color = vbRed
- Else
- Sheets("Sheet1").Cells(iCntr, 9).Interior.Color = vbGreen
- End If
- End If
- iTrack = iTrack + 1
- Next
- Next
- End Sub
- Private Sub Worksheet_Change(ByVal Target As Range)
- Dim curColor As Variant
- curColor = ActiveCell.Interior.Color
- If Application.CountIf(Range("A:A"), Target) > 1 Then
- MsgBox "Duplicate Data", vbCritical, "Remove Data"
- Target.value = ""
- 'ActiveCell.Offset(RowOffset:=-1).EntireRow.Interior.Color = curColor
- End If
- End Sub
- Private Sub Worksheet_SelectionChange(ByVal Target As Range)
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement