Excel VBA - 搜索特定字符，选择没有该字符的任何非空单元格，对所选单元格执行第二个子程序

Excel VBA - Search for a specific character, select any non-empty cells without that character, perform a second subroutine on the selected cells

提问by Queenslander

I'm a newbie to Excel VBA (only one formal course so far), and I've been trying to cobble together a VBA macro using bits and pieces gleaned from this and other Excel sites, but after several days I feel that I've reached an impasse.

我是 Excel VBA 的新手（到目前为止只有一门正式课程），我一直在尝试使用从这个网站和其他 Excel 网站收集的零碎碎片拼凑一个 VBA 宏，但几天后我觉得我已经陷入僵局。

What I'm trying to do:

我正在尝试做的事情：

• Search Columns C, D, E, G, H, I, K, L for the character "°", beginning with Row 6, ending with Row 200 for each of the above columns.
• If "°" appears in any cell in the above ranges, then no action is taken on that cell.
• If the cell is completely empty, then no action is taken on that cell.
• If "°" does NOT appear in any cell in the above ranges, and the cell is NOT completely empty, then the cell is selected or activated, and a second subroutine is called.
• The second subroutine places the "°" character in the 5th position from the end of the cell (equivalent to hitting F2, moving left 5 positions, and inserting "°").

• 搜索列 C、D、E、G、H、I、K、L 以查找字符“°”，从第 6 行开始，以第 200 行结束上述每一列。
• 如果“°”出现在上述范围内的任何单元格中，则不会对该单元格执行任何操作。
• 如果单元格完全为空，则不会对该单元格执行任何操作。
• 如果“°”没有出现在上述范围内的任何单元格中，并且该单元格不是完全空的，则选择或激活该单元格，并调用第二个子程序。
• 第二个子程序将“°”字符放置在距单元格末尾的第 5 个位置（相当于按 F2，向左移动 5 个位置并插入“°”）。

The latest version of what I've written:

我写的最新版本：

Sub CheckTestColC()
     Dim a As String
     Dim cell As C6: C200
     For Each cell In Selection
       If InStr(1, cell, "°", 1) Then
       Cells(ActiveCell.Row + 1, ActiveCell.Column).Select
       Else
       ActiveCell.Value = a
       Call AddDegree
       End If
     Next
     End Sub

Sub AddDegree()

    SendKeys "{F2}"
    Application.Wait (Now() + TimeValue("00:00:01"))
    SendKeys "{LEFT 5}"
    Application.Wait (Now() + TimeValue("00:00:01"))
    SendKeys "°"
    Application.Wait (Now() + TimeValue("00:00:01"))
    SendKeys "{ENTER}"

 End Sub

Again, I am a complete novice to this, so I apologize in advance if my coding seems ridiculous to you experienced folks. ;-)

再说一次，我完全是新手，所以如果我的编码对你们有经验的人来说很荒谬，我提前道歉。;-)

I'm happy to see corrections to the above coding, or if there are "better/stronger/faster" ways to solve this using a completely different path, then please steer me in the right direction. I very much want to learn! :)

我很高兴看到对上述编码的更正，或者如果有“更好/更强/更快”的方法来使用完全不同的路径来解决这个问题，那么请引导我朝着正确的方向前进。我非常想学习！:)

回答by chris neilsen

Since you say you are so new to VBA here's an example of you code that demonstrates a few concepts worth learning.

由于您说您对 VBA 非常陌生，这里有一个代码示例，演示了一些值得学习的概念。

1. Abstract your logic from your inputs. That way you can reuses the code more easily
2. Restrict the size of loops over ranges (they are slow). SpecialCellshelps to reduce the range to potential cells of interest. Even better, use a Variant Array (look it up on SO)
3. Don't use SendKeys. Ever. (well, unless you have a really, really good reason)
4. Handle potential input anomalies

1. 从您的输入中抽象出您的逻辑。这样你就可以更轻松地重用代码
2. 限制范围内循环的大小（它们很慢）。 SpecialCells有助于减少对潜在感兴趣单元格的范围。更好的是，使用 Variant Array（在 SO 上查找）
3. 不要使用 SendKeys。曾经。（好吧，除非你有一个非常非常好的理由）
4. 处理潜在的输入异常

---

---

Sub Demo()
    ' Process Rows 6:200 of columns C, D, E, G, H, I, K, L on active sheet
    FindDeg Range("C6:E200"), "°", 5, False
    FindDeg Range("G6:I200"), "°", 5, False
    FindDeg Range("K6:L200"), "°", 5, False
End Sub

Private Sub FindDeg(rng As Range, InsertString As String, AtPosition As Long, Optional FromLeft As Boolean = True)
    Dim rngTextCells As Range, cl As Range
    Dim str As String

    ' Select non-blank cells containing text
    ' (ie ignore formulas, numbers and errors)
    On Error Resume Next
    Set rngTextCells = rng.SpecialCells(xlCellTypeConstants, xlTextValues)
    Err.Clear
    On Error GoTo 0

    ' If any found
    If Not rngTextCells Is Nothing Then
        '  Loop through cells
        For Each cl In rngTextCells
            If Not cl.Value Like "*" & InsertString & "*" Then
                ' Cell does not contain °
                str = CStr(cl.Value)
                If Len(str) < AtPosition Then
                    ' what if it's too short?
                    MsgBox "cell = " & str & vbNewLine & "What now?"
                    Exit Function
                End If

                ' Insert string at position (no need to that SensKeys nonsense
                If FromLeft Then
                    cl = Left$(str, AtPosition) & InsertString & Mid$(str, AtPosition + 1)
                Else
                    cl = Left$(str, Len(str) - AtPosition) & InsertString & Right$(str, AtPosition)
                End If
            End If
        Next
    End If
End Sub

回答by stenci

The example below requires some tuning, but it is close to what you need.

下面的例子需要一些调整，但它接近你所需要的。

I used simple techniques that you should be able to understand, perhaps with some googleing. Look for help with Excel VBA, not with Excel. VBA doesn't talk to Excel via the keyboard (i.e. forget SendKeys), and doesn't need to select cells to modify them (i.e. forget Select).

我使用了您应该能够理解的简单技术，也许通过一些谷歌搜索。寻求有关 Excel VBA 的帮助，而不是 Excel。VBA 不通过键盘与 Excel 对话（即忘记SendKeys），也不需要选择单元格来修改它们（即忘记Select）。

For VBA every cell, worksheet, workbook, range, font, chart, etc. are objects. You can "read" or "write" them using their method and properties.

对于 VBA，每个单元格、工作表、工作簿、范围、字体、图表等都是对象。您可以使用它们的方法和属性“读取”或“写入”它们。

Sub CheckTestColC()
  Dim R As Integer, C As Integer, CLetter As String
  For C = 1 To 10
    CLetter = Chr(C + 64)
    If InStr("CDEGHIKL", CLetter) = 0 Then GoTo SkipColumn
    For R = 6 To 200
      If IsEmpty(Cells(R, C)) Then GoTo SkipRow
      If InStr(Cells(R, C).Value, "°") Then GoTo SkipRow
      Cells(R, C).Value = ModifyValue(Cells(R, C).Value)
SkipRow:
    Next R
SkipColumn:
  Next C
End Sub

Function ModifyValue(Txt As String)
  ModifyValue = Left(Txt, 4) & "°" & Mid(Txt, 5)
End Function

回答by EkriirkE

I would not use SendKeys as it requires the user to not use the machine at all until it completes, and any other interruptions like popups will also break it. I would use Left() and Right() instead. Activating the cell is not required with this method,either.

我不会使用 SendKeys，因为它要求用户在完成之前根本不要使用机器，并且任何其他中断（如弹出窗口）也会破坏它。我会改用 Left() 和 Right()。这种方法也不需要激活细胞。

You don't appear to be checking the cell has content as you explain.

您似乎没有按照您的解释检查单元格是否包含内容。

The variable "a" has no assigned value, so you are in effect blanking the cells using it.

变量“a”没有赋值，因此您实际上是在使用它来消隐单元格。

"Cells(ActiveCell.Row + 1, ActiveCell.Column).Select" Will not select the cell "cells" refers to, it will just keep selecting the next cell down.

"Cells(ActiveCell.Row + 1, ActiveCell.Column).Select" 不会选择"cells"所指的单元格，它只会继续选择下一个单元格。

Here is a rough re-write, I don't have Excel on this machine, but this is closer to your explained logic (without the need for a 2nd sub). This version requires the cell content to be at least 5 chars to meet your 5-from-end criteria

这是一个粗略的重写，我在这台机器上没有 Excel，但这更接近你解释的逻辑（不需要第二个子）。此版本要求单元格内容至少为 5 个字符才能满足您的 5-from-end 条件

Sub CheckTestColC()
     Dim cell As C6: C200
     For Each cell In Selection
       If InStr(cell, "°")<1 And Len(cell)>=5 Then
         'cell.Select  'Not required
         cell=Left(cell,len(cell)-5) & "°" & Right(cell,5)
       End If
     Next
End Sub

回答by brettdj

Welcome to StackOverflow and well done on your question and learning to-date!

欢迎使用 StackOverflow，您的问题和学习都做得很好！

In terms of "stronger/better/faster"

在“更强/更好/更快”方面

• Avoid looping through cell ranges, use a variant array for the manipulations instead
• Steer clear of Sendkeys,it's kludgy
• Before adding to a string in the 5th position, test that it is at least 4 characters first
• Use string functions Left$rather than the slower variants Left

• 避免遍历单元格范围，而是使用变体数组进行操作
• 避开Sendkeys,它的笨拙
• 在添加到第 5 个位置的字符串之前，先测试它至少是 4 个字符
• 使用字符串函数Left$而不是较慢的变体Left

This code works on your entire range, skipping columns Fand J

此代码适用于您的整个范围，跳过列F和J

Sub Uppdate() 
Dim X 
Dim rng1 As Range 
Dim lngCol As Long 
Dim lngRow As Long 
 'set initial range
Set rng1 = Range("C6:L200") 
 'put range in variant
X = rng1.Value2 
For lngCol = 1 To UBound(X, 2) 
    For lngRow = 1 To UBound(X, 1) 
         'skip every fourth column (F and J)
        If lngCol Mod 4 <> 0 Then 
             'skip values containing "°"
            If InStr(X(lngRow, lngCol), "°") = 0 Then 
                 'replace is string is 4 or more characters
                If Len(X(lngRow, lngCol)) > 3 Then 
                    X(lngRow, lngCol) = Left$(X(lngRow, lngCol), 4) & "°" & Right$(X(lngRow, lngCol), Len(X(lngRow, lngCol)) - 4) 
                End If 
            End If 
        End If 
    Next lngRow 
Next lngCol 
 'dump back to range
rng1 = X 
End Sub