I have this macro and it works but not the way I hoped. I am trying to get the macro to find the lower case names and pull them out.

What I have come up with is a macro that will find the lower case names and capitalize them. I aslo have a step that will bold and change the color to red, excpet it changes the entire "h" column red and bold.

What I would like is to have the macro find the lowercase and copy them to a new cell in the same row, can anyone help me.

Here is my current macro:
Sub Upper_Case1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Cell As Range
On Error Resume Next 'In case no cells in selection
For Each Cell In Intersect(Selection, _
Selection.SpecialCells(xlConstants, xlTextValues))
Cell.Formula = UCase(Cell.Formula)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Selection.Font.Bold = True
With Selection.Font
.Name = "Tahoma"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 3
End With
End Sub