excel 2010 vba使单元格处于活动状态

Question

我正在尝试编写一个 Excel 宏，该宏将获取一列数据并针对格式错误进行编辑。背景：

1. 电子表格发送到公司，其中包含三个名称列 - LName、FName、MI
2. 公司将其寄回，通常带有 FName 和 MI 组合或带有完整的中间名
3. 如果单个名称出现错误 - 例如MI 是全名，FName 中有空格，MI 包含在 FName 中，MI 是零而不是字母等。

我不想每月手动检查近两千个名字。这是一种痛苦。所以我想我会写一个执行以下操作的宏：

1. 能够循环
2. 如果 MI 在 FName 列中，请将其拉​​出并将其粘贴到下一列中
3. “修剪”或删除 FName 列中的空格和任何后续文本

最后我想添加一些其他的东西，但是一旦我弄清楚了它们似乎很简单。

问题：

整个 sub 似乎从一个单元格运行，从不更改活动单元格，因此实际上并没有完成任何事情。 IF 语句似乎认为每个 FName 列中都有一个空格，这是不正确的。我很肯定这是另一个“额外的眼睛”的东西，但我感觉非常愚蠢，我知道我的大脑有点被术后止痛药弄糊涂了。我什至不应该在工作（呃，现在闭嘴）。

即使我尝试选择并激活它应该在的单元格，它仍然保留在我通过所有迭代手动选择的任何单元格中，永远不会改变，只是将文本的最后一个字母放入下一个单元格中是否存在空间与否。所以项目符号格式的问题是：

1. 未选择/激活正确的单元格。
2. If 语句返回的是肯定的，即使它不应该返回。
3. If 语句因此打破了整个愚蠢的事情。

无论如何。这是代码，虽然出于 HIPAA 的原因我无法共享电子表格，但可以做出以下安全假设：

F 列有姓氏，G 列应该有名字，但通常包括名字、空格和中间名首字母（例如 BOB C 而不是 BOB），最后，H 列应该只有中间名首字母，但通常有完整的中间名如果此人没有中间名，则为 0（例如 CHARLES 而不是 C 或只有 0）。稍后我将在此函数或其他函数中将零更改为“”并将完整的中间名修剪为首字母。

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

如果我没有很好地解释自己，请告诉我，我会努力做得更好。

Answer 1

试试这个。我使用InStr 函数而不是Find。

还请注意，您应该尽可能避免使用 Selection 和 ActiveCell，这大约是 99% 的时间 :)

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

另外，去掉On Error Resume Next 语句。除了假装错误没有发生之外，这没有任何作用，并且通常会导致进一步的错误。更好的办法是捕获错误、突出显示这些单元格或执行其他操作以通知用户遇到了错误。

更新

如果处理数千条记录时可能会出现性能问题，请考虑改用它。名称将被加载到内存中的数组中，所有操作都将在内存中执行，然后将生成的数组（名称、初始值各一个）写入工作表。这应该比遍历每个单元格以及将值写入每行/列数千次要快得多。

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