Question

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

电子表格被发送到公司，其中包含三个名称列--LName，FName，MI
公司将其发回，通常使用合并的FName和MI或完整的中间名
如果单个名称错误地显示，则状态会抛出拟合并拒绝整个列表 - 例如MI是一个全名，FName中有一个空格，MI包含在FName中，MI是零而不是字母等。

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

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

最终我想添加一些其他的东西，但是一旦我弄明白它们就显得很简单。

问题：

整个sub似乎从一个单元格运行，从不更改活动单元格，因此实际上没有完成任何任何操作。 IF语句似乎认为每个FName列都有一个空格，这不是真的。我很肯定这是另一个“额外的眼睛”的事情，但我感觉非常愚蠢，我知道我的大脑有点混乱的手术后疼痛药物。我甚至不应该工作（呃，现在关门）。

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

未选择/激活正确的单元格。
如果声明即使不应该返回肯定的话。
如果声明因此打破了整个愚蠢的事情。

总之。这是代码，虽然由于HIPAA的原因我无法共享电子表格，但这些都是安全的假设：

列F有姓氏，G列应该有名字，但通常包括名字，空格和中间名（例如BOB C而不是BOB），最后H列应该只有中间名，但通常有完整的中间名如果此人没有中间名，则为零（例如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

excel 2010 vba让细胞活跃起来

1 个答案: