遍历列并检查单元格是否包含特定字符

Question

我需要帮助，试图弄清楚 Instr 函数是否能做到这一点。
在一个单元格中，我有一些文本和数字（例如：Overlay 700 MHz - 06_469）
看到最后的数字了吗？ 2 个数字，后跟 _（下划线）或任何字母，然后是另外 3 个数字。

有没有办法在特定的列中搜索它，如果找到，只复制这些特定的组合？注意：它可以在单元格中的任何位置，开始、结束、中间等......

Answer 1

编辑 - 使用正则表达式进行泛型匹配，解决已澄清的问题。

使用正则表达式 (RegExp) 匹配模式“2 位，1 位非数字，3 位”。您将需要添加正则表达式参考。在 VBA 编辑器中，转到 Tools>References 并勾选

Microsoft VBScript Regular Expressions 5.5 

然后将以下函数添加到您的模块中：

Function RegexMatch(Myrange As Range) As String
    RegexMatch = ""

    Dim strPattern As String: strPattern = "[0-9]{2}[a-zA-Z_\-]{1}[0-9]{3}"
    Dim regEx As New RegExp
    Dim strInput As String
    strInput = Myrange.Value

    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = strPattern
    End With

    If regEx.Test(strInput) Then
        RegexMatch = regEx.Execute(strInput)(0)
    End If
End Function

然后像这样使用它：

Dim myCell As Range
Dim matchString As String
For Each myCell In Intersect(ActiveSheet.Columns("A"), ActiveSheet.UsedRange)
    matchString = RegexMatch(myCell)
    ' Copy matched value to another column
    myCell.Offset(0, 1).Value = matchString
Next myCell

结果：

有关 VBA RegExp 的更多信息，请参阅这个 SO 问题：

How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops

---

原始 - 使用Instr 进行搜索字符串匹配。

你说得对，Instr 函数就是你想要的，如果字符串不在字符串中，则返回0，否则返回索引大于0。

Dim myString as String
myString = "Overlay 700 MHz - 06_469"
Dim myDigitString as String
' Use RIGHT to get the last 6 characters (your search string)
myDigitString = Right(myString, 6)

Dim myCell as Range
' Cycle through cells in column A, which are also in the sheet's used range
For each myCell in Intersect(ActiveSheet.Columns("A"), ActiveSheet.UsedRange)

    If Instr(myCell.Value, myDigitString) > 0 Then

        ' Copy cell to another sheet
        myCell.copy Desination:=ActiveWorkbook.Sheets("PasteToThisSheet").Range("A1")

        ' If you only want to get the first instance then...
        Exit For

    End If

Next myCell

要匹配模式“2 位，另一个字符，3 位”，您可以使用：

For each myCell in Intersect(ActiveSheet.Columns("A"), ActiveSheet.UsedRange)

    ' Check that first 2 digits and last 3 digits are in cell value
    ' Also check that they are separated by 1 character
    If Instr(myCell.Value, Left(myDigitString,2)) > 0 And _
       Instr(myCell.Value, Right(myDigitString,3)) > 0 And
       Instr(myCell.Value, Right(myDigitString,3)) - Instr(myCell.Value, Left(myDigitString,2)) = 3 Then

        ' Copy cell to another sheet
        myCell.copy Desination:=ActiveWorkbook.Sheets("PasteToThisSheet").Range("A1")

        ' If you only want to get the first instance then...
        Exit For

    End If

Next myCell

Answer 2

使用 [regex] 查找“两个数字-下划线-三个数字”模式。

Option Explicit

Sub pullSerialNumbers()
    Dim n As Long, strs() As Variant, nums() As Variant
    Dim rng As Range, ws As Worksheet
    Dim rgx As Object, cmat As Object

    Set rgx = CreateObject("VBScript.RegExp")
    Set cmat = Nothing
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ReDim Preserve nums(0)

    With ws
        strs = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
    End With

    With rgx
        .Global = True
        .MultiLine = True
        .Pattern = "[0-9]{2}\_[0-9]{3}"
        For n = LBound(strs, 1) To UBound(strs, 1)
            If .Test(strs(n, 1)) Then
                Set cmat = .Execute(strs(n, 1))
                'resize the nums array to accept the matches
                ReDim Preserve nums(UBound(nums) + 1)
                'populate the nums array with the match
                nums(UBound(nums) - 1) = cmat.Item(cmat.Count - 1)
            End If
        Next n
        ReDim Preserve nums(UBound(nums) - 1)
    End With

    With ws
        .Cells(2, "C").Resize(.Rows.Count - 1).Clear
        .Cells(2, "C").Resize(UBound(nums) + 1, 1) = _
            Application.Transpose(nums)
    End With

End Sub

这假设在任何一个单元格中只能找到一个匹配项。如果还有更多，则遍历匹配项并添加每个匹配项。

Answer 3

D列中有数据：

Sub marine()
    Dim r As Range

    For Each r In Intersect(Range("D:D"), ActiveSheet.UsedRange)
        s = r.Value
        If s <> "" And InStr(s, "_") <> 0 Then
            ary = Split(s, "_")
            r.Offset(0, 1).Value = Right(ary(0), 2) & "_" & Left(ary(1), 3)
            End If
    Next r
End Sub

这种方法存在几个问题：

• 文本开头或结尾的下划线
• 字符串中有多个下划线
• 用字母包围的下划线。