Hi All,
I'm trying to check out repeated value on column Q and the hightlighted
entire cell on the left.I put the code that found from Sample,and trying
to modified it but I made a mistake.I can't select entire cell on the left,
I just can highlight 2 cell ( offset(0.-3) and the cell on column A).Please
help how to select entire cell to the left without interupted by blank cell.

And also I want to put the copy of higlighted cell value to a new workbook.

Thank's.

Rgds,


Shiro


Sub Duplicate_Serial_Number()

Dim eX As Integer
Dim cell_in_loop As Range

eX = ActiveSheet.Evaluate("COUNTIF(Q:Q,"">1"")")

If eX = 0 Then
MsgBox "There is no duplicated serial number ", vbExclamation _
+ vbOKOnly, "No Duplicated Data"
Else
For Each cell_in_loop In Range("Q16:Q50000")
If cell_in_loop.Value > 1 And _
cell_in_loop.Value <> "" Then
With cell_in_loop.Offset(0, -3).End(xlToLeft).Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
Next
End If
End Sub

One way:

Option Explicit
Sub Duplicate_Serial_Number()

Dim myCell As Range
Dim LastRow As Long
Dim myRng As Range
Dim myRngToShade As Range

With ActiveSheet
'clean up any previous shading
.Cells.Interior.ColorIndex = xlNone
LastRow = .Cells(.Rows.Count, "Q").End(xlUp).Row
Set myRng = .Range("Q16:Q" & LastRow)

If Application.Max(myRng) < 2 Then
MsgBox "There is no duplicated serial number ", vbExclamation _
+ vbOKOnly, "No Duplicated Data"
Else
For Each myCell In myRng.Cells
If myCell.Value > 1 Then
Set myRngToShade = .Range(.Cells(myCell.Row, "A"), _
.Cells(myCell.Row, "N"))
With myRngToShade.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
End If
Next myCell
End If
End With

End Sub

=======
Colors are pretty, but I like to use that extra column (Q) and then use
data|Filter|autofilter to see the duplicates.



shiro wrote:
>
> Hi All,
> I'm trying to check out repeated value on column Q and the hightlighted
> entire cell on the left.I put the code that found from Sample,and trying
> to modified it but I made a mistake.I can't select entire cell on the left,
> I just can highlight 2 cell ( offset(0.-3) and the cell on column A).Please
> help how to select entire cell to the left without interupted by blank cell.
>
> And also I want to put the copy of higlighted cell value to a new workbook.
>
> Thank's.
>
> Rgds,
>
> Shiro
>
> Sub Duplicate_Serial_Number()
>
> Dim eX As Integer
> Dim cell_in_loop As Range
>
> eX = ActiveSheet.Evaluate("COUNTIF(Q:Q,"">1"")")
>
> If eX = 0 Then
> MsgBox "There is no duplicated serial number ", vbExclamation _
> + vbOKOnly, "No Duplicated Data"
> Else
> For Each cell_in_loop In Range("Q16:Q50000")
> If cell_in_loop.Value > 1 And _
> cell_in_loop.Value <> "" Then
> With cell_in_loop.Offset(0, -3).End(xlToLeft).Interior
> .ColorIndex = 6
> .Pattern = xlSolid
> End With
> End If
> Next
> End If
> End Sub

--

Dave Peterson