ok try this:
Sub FindOnes()
Dim MyRg As Range, CCol As Range, CCell As Range, MyVal, ColC As String, IsDups As Boolean
Set MyRg = ActiveSheet.UsedRange
ColC = ""
For Each CCol In MyRg.Columns
MyVal = ""
IsDups = True
For Each CCell In CCol.Cells
If CCell.Row <> 1 And MyVal = "" And CCell <> "" Then MyVal = CCell
If CCell.Row <> 1 And CCell <> MyVal And CCell <> "" Then
IsDups = False
GoTo nXtC
End If
Next CCell
If IsDups = True And MyVal <> "" Then ColC = ColC & " " & CCol.Cells(1).Address(0, 0)
nXtC:
Next CCol
If ColC <> "" Then MsgBox "these columns have duplicate values:" & Replace(ColC, 1, "") Else MsgBox "no columns have duplicate values"
End Sub
Bookmarks