excel 2010 vba 激活单元格

excel 2010 vba make cell active

提问by Angela

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

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

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.

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

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

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

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).

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

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.

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

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

无论如何。这是代码，虽然由于 HIPAA 的原因我不能分享电子表格，但这些是安全的假设：

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.

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

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

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

回答by David Zemens

Try this instead. I use the InStrfunction instead of Find.

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

Note also that you should avoid using Selectionand ActiveCellwhenever possible, which is about 99% of the time :)

另请注意，您应该尽可能避免使用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

Also, get rid of the On Error Resume Nextstatement. 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.

此外，摆脱On Error Resume Next声明。除了假装没有发生错误外，这不会做任何事情，并且通常会导致进一步的错误。更好的想法是捕获错误，突出显示这些单元格，或执行其他操作以通知用户遇到错误。

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