1

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

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

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

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

最终我想添加一些其他的东西，但是一旦我弄清楚了，它们看起来很简单。

问题：

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

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

  1. 未选择/激活正确的单元格。
  2. if 语句即使不应该返回正值。
  3. 因此，如果声明打破了整个愚蠢的事情。

无论如何。这是代码，虽然出于 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

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

4

1 回答 1

2

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

另请注意，您应该尽可能避免使用Selectionand 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
于 2013-05-20T16:09:00.387 回答