excel 2010 vba make cell active

Question

I'm attempting to write an Excel macro that will take a column of data and edit for formatting errors. Background:

1. Spreadsheet gets sent out to company with three name columns - LName, FName, MI
2. Company sends it back, usually with combined FName and MI or with full middle name
3. The state throws a fit and rejects the entire list if a single name comes across incorrectly - e.g. MI is a full name, there is a space in FName, the MI is included in the FName, MI is a zero instead of a letter, etc.

I don't want to manually check nearly two thousand names once a month. It's a pain. So I figured I'd write a macro that does the following:

1. be able to loop
2. pull the MI if it's in the FName column and paste it into the next column
3. "trim" or delete the space and any following text in the FName column

Eventually I want to add a few other things, but they seem simple once I get this figured out.

The problem:

The entire sub seems to run from one cell, never changes the active cell, and therefore doesn't actually accomplish anything. The IF statement seems to think there is a space in every FName column, which isn't true. I'm positive this is another of those "extra pair of eyes" things, but I'm feeling awfully stupid and I know my brain is a little muddled with post-surgical pain meds. I shouldn't even BE at work (ugh, shutting up now).

Even though I try to select AND activate the cell it SHOULD be on, it stays in whatever cell I've manually selected through all iterations, never changes, just plops the last letter of text into the next cell over whether there's a space or not. So the problems in bullet format are:

1. Not selecting/activating the right cell(s).
2. If statement is returning a positive even when it shouldn't.
3. If statement is therefore breaking the whole stupid thing.

Anyhow. Here's the code, and while I can't share the spreadsheet for HIPAA reasons, these are safe assumptions to be made:

Column F has last names, Column G SHOULD have first names but often includes first names, a space and a middle initial (e.g. BOB C instead of BOB) and finally Column H SHOULD have only middle initials but often has full middle names or a zero if the person does not have a middle name (e.g. CHARLES instead of C or just a 0). I will get around to changing zeros to "" and trimming full middle names to initials in this or another function later.

Sub ReduceToInitial()

Dim strInit As String
Dim strName As String
Dim r As Excel.Range
Dim rCell As Excel.Range
Dim lr As Long
Dim oSht As Worksheet
Set oSht = Application.ActiveSheet
lr = Cells(Rows.Count, "G").End(xlUp).Row
Set r = oSht.Range("G2:G" & lr)
Range("G2").Select
Range("G2").Activate
On Error Resume Next
For Each rCell In r
Range(rCell).Select
Range(rCell).Activate
    If rCell.Find(" ", rCell) <> 0 Then
        strInit = Right(rCell, 1)
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Formula = strInit
        ActiveCell.Offset(0, -1).Select
        strName = rCell.Left(rCell, rCell.Find(" ", rCell) - 1)
        ActiveCell.Formula = strName
    End If
Next rCell

End Sub

Please let me know if I haven't explained myself very well and I will try to do better.

Answer 1

Try this instead. I use the InStr function instead of Find.

Note also that you should avoid using Selection and ActiveCell whenever possible, which is about 99% of the time :)

Sub ReduceToInitial()

Dim strInit As String
Dim strName As String
Dim r As Excel.Range
Dim rCell As Excel.Range
Dim lr As Long
Dim oSht As Worksheet
Set oSht = Application.ActiveSheet
lr = Cells(Rows.Count, "G").End(xlUp).Row
Set r = oSht.Range("G2:G" & lr)

For Each rCell In r
    With rCell
        If InStr(1, .Value, " ", vbBinaryCompare) <> 0 Then
            strInit = Right(rCell, 1)
            .Offset(0, 1).Formula = strInit
            strName = Left(rCell, InStr(1, .Value, " ", vbBinaryCompare) - 1)
            .Formula = strName
        End If
    End With
Next rCell

End Sub

Also, get rid of the On Error Resume Next statement. That doesn't do anything except pretend that errors didn't happen, and can often result in further errors. Better idea would be to trap errors, highlight those cells, or do something else to notify the user that an error was encountered.

Updated

If performance may be an issue working with many thousands of records, consider using this instead. The names will be loaded in to an array in memory, all operations will be performed in memory, and then the resulting arrays (one each for name, initial) will be written to the worksheet. This should be much faster than iterating over each cell, and writing values to each row/column thousands of times.

Sub ReduceToInitial2()

Dim strName As Variant
Dim arrNames() As Variant
Dim arrInit() As Variant
Dim s As Long
Dim strSplit As Long

Dim r As Excel.Range
Dim rCell As Excel.Range
Dim lr As Long
Dim oSht As Worksheet
Set oSht = Application.ActiveSheet
lr = Cells(Rows.Count, "G").End(xlUp).Row
Set r = oSht.Range("G2:G" & lr)
arrNames = r

'Make sure the array containers are properly sized
ReDim arrInit(1 To UBound(arrNames))

'Iterate over the names in arrNames
For Each strName In arrNames
    s = s + 1
    strSplit = InStr(1, strName, " ", vbBinaryCompare)
    If strSplit <> 0 Then
        arrInit(s) = Right(strName, 1)
        arrNames(s, 1) = Left(strName, strSplit - 1)
    End If
Next

'Put the values on the worksheet
r.Value = arrNames
r.Offset(0, 1).Value = Application.Transpose(arrInit)


End Sub