Scrol window
 

Hi experts
Code below finds and marks cells red if value is uniqus
Problem is that if i select a large range i cant se all red-marked cells
Is there a way to scroll window while code is running ?

Sub RemoveUniqs()
Dim rng As Range
Dim rng2 As Range
Set rng = Selection
rng.Interior.ColorIndex = xlNone
For Each c In rng
If WorksheetFunction.CountIf(rng, c.Value) = 1 Then
If rng2 Is Nothing Then
Set rng2 = c
Else
Set rng2 = Application.Union(rng2, c)
End If
End If
Next

rng2.Interior.ColorIndex = 3
Title = " Uniqs value is colored red ! what now ?"
choice1 = "Type 1 Clear value"
choice2 = "Type 2 Clear value and move cells up"
choice3 = "Type 3 Delete entire row"
choice = InputBox("" & choice1 & Chr(10) & choice2 & Chr(10) & choice3 & "",
Title)
If choice = 1 Then rng2 = ""
If choice = 2 Then rng2.Delete Shift:=xlUp
If choice = 3 Then rng2.EntireRow.Delete
End Sub

Scrol window
 

You could use this technique to scroll, by placing the snippet on the line
after where you add the color.

ActiveWindow.ScrollColumn = Selection.Cells.Count / 2
MsgBox "Look"
ActiveWindow.ScrollColumn = 1

You can adjust it to look further or less. The last line returns it to full
left justify.


"excelent" wrote in message
...
Hi experts
Code below finds and marks cells red if value is uniqus
Problem is that if i select a large range i cant se all red-marked cells
Is there a way to scroll window while code is running ?

Sub RemoveUniqs()
Dim rng As Range
Dim rng2 As Range
Set rng = Selection
rng.Interior.ColorIndex = xlNone
For Each c In rng
If WorksheetFunction.CountIf(rng, c.Value) = 1 Then
If rng2 Is Nothing Then
Set rng2 = c
Else
Set rng2 = Application.Union(rng2, c)
End If
End If
Next

rng2.Interior.ColorIndex = 3
Title = " Uniqs value is colored red ! what now ?"
choice1 = "Type 1 Clear value"
choice2 = "Type 2 Clear value and move cells up"
choice3 = "Type 3 Delete entire row"
choice = InputBox("" & choice1 & Chr(10) & choice2 & Chr(10) & choice3 &
"",
Title)
If choice = 1 Then rng2 = ""
If choice = 2 Then rng2.Delete Shift:=xlUp
If choice = 3 Then rng2.EntireRow.Delete
End Sub