在 Excel 范围 VBA 中查找子字符串

Question

我有一个范围内的输入文本字符串（从 A1 到 AV1），每个字母在一个单元格中。字符串是

从 A1 到 AV1 是这样的

  | A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA AB AC AD AE AF AG AH AI AJ AK AL AM AN AO AP AQ AR AS AT AU AV
--------------------------------------------------------------------------------------------------------------------------
1 | M i c r o s o f t E x c e l i s a s p r e a d s h e e  t  d  e  v  e  l  o  p  e  d  b  y  M  i  c  r  o  s  o  f  t

我希望能够搜索子字符串，如果找到，请选择子字符串所在的范围。

如果输入文本字符串在同一行中，我下面的当前代码可以工作，但我不知道该怎么做 如果字符串在不同的行中，例如，如果相同的输入文本字符串在 A1:O4 范围内并且我想 搜索从 N2 开始到 G3 结束的子字符串“开发”。

Sub SelectRangeofSubString()
Rng = Range("A1:AV1")

a = Range("A1").CurrentRegion
aa = WorksheetFunction.Transpose(WorksheetFunction.Transpose(a))
str1 = Join(aa, "")

StringToSearch = "developed"
StringLength = Len(StringToSearch)
Pos = InStr(str1, StringToSearch)

Range(Cells(1, Pos), Cells(1, Pos + StringLength - 1)).Select

End Sub

从 A1 到 O4 是这样的

  | A   B   C   D   E   F   G   H   I   J   K   L   M   N   O
---------------------------------------------------------------
1 | M   i   c   r   o   s   o   f   t   E   x   c   e   l   i
2 | s   a   s   p   r   e   a   d   s   h   e   e   t   d   e
3 | v   e   l   o   p   e   d   b   y   M   i   c   r   o   s
4 | o   f   t                                               

感谢您的帮助

更新

谢谢两位。它适用于两种解决方案。我的上一个问题，当每个单元格包含2个字母时，我尝试了相同的方法，请问您也可以帮我选择这种情况下的范围吗？

例如 stringToSearch = " Developed" 并且数据来自范围 A1:H3

    A   B   C   D   E   F   G   H
----------------------------------
1 | Mi  cr  os  of  tE  xc  el  is
2 | as  pr  ea  ds  he  et  de  ve
3 | lo  pe  db  yM  ic  ro  so  ft

Answer 1

我根据我们必须查看的信息修改了您的代码 ar Range("A1:O4")

Sub SelectRangeofSubString()
Dim rng As Range
Dim a, str1, stringtosearch, stringlength, pos
Dim i As Long, j As Long
    Set rng = Range("A1:O4")

    a = rng ' Range("A1").CurrentRegion
    'aa = WorksheetFunction.Transpose(WorksheetFunction.Transpose(a))
    For i = LBound(a, 1) To UBound(a, 1)
        For j = LBound(a, 2) To UBound(a, 2)
            str1 = str1 & a(i, j)
        Next
    Next

    stringtosearch = "developed"
    stringlength = Len(stringtosearch)
    pos = InStr(str1, stringtosearch)

    Dim resRg As Range
    Set resRg = rng.Item(pos)
    For i = pos + 1 To pos + Len(stringtosearch) - 1
        Set resRg = Union(resRg, rng.Item(i))
    Next i
    resRg.Select

End Sub

Answer 2

我把这个问题变成了一个小子程序，它将一个 SearchRange 和 SearchString 作为参数。

子例程将选择找到第一个匹配项的单元格。如果您想返回 Range 对象，应该很容易切换它。

Private Sub FindWord(SearchRange As Range, SearchString As String)
    Dim LetterArray         As Variant
    Dim RangeArray          As Variant
    Dim ws                  As Worksheet
    Dim Letter              As Range
    Dim i                   As Long
    Dim SelectedRng         As Range
    Dim StringPosition      As Long
    Dim LastSearchIndex     As Long

    ReDim LetterArray(1 To SearchRange.Cells.Count)
    ReDim RangeArray(1 To SearchRange.Cells.Count)
    Set ws = SearchRange.Parent

    For Each Letter In SearchRange
        i = i + 1
        LetterArray(i) = Letter.Value2
        RangeArray(i) = Letter.Address
    Next

    StringPosition = InStr(1, Join(LetterArray, vbNullString), SearchString)
    If StringPosition <= 0 Then Exit Sub
    LastSearchIndex = Len(SearchString) + StringPosition - 1

    For i = StringPosition To LastSearchIndex
        If SelectedRng Is Nothing Then
            Set SelectedRng = ws.Range(RangeArray(i))
        Else
            Set SelectedRng = Union(SelectedRng, ws.Range(RangeArray(i)))
        End If
    Next

    SelectedRng.Select
End Sub

Sub SelectIt()
    Dim rng As Range
    Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:D4")

    FindWord rng, "developed"
End Sub

编辑

---

对此进行了更新以在一个单元格中处理 2 个或更多字符。这应该适用于最多N 个字符，但我只是简单地测试了这一点。我希望它有所帮助。我将把另一种方法留给后代。

我应该提到这个修改后的方法确实假设所有单元格中都有相同数量的字符。如果这不是真的，它可能不会起作用。

Private Sub FindWord(SearchRange As Range, SearchString As String, Optional CharacterLength As Long = 1)
    Dim LetterArray         As Variant
    Dim RangeArray          As Variant
    Dim ws                  As Worksheet
    Dim Letter              As Range
    Dim i                   As Long
    Dim SelectedRng         As Range
    Dim StringPosition      As Long
    Dim LastSearchIndex     As Long

    ReDim LetterArray(1 To SearchRange.Cells.Count)
    ReDim RangeArray(1 To SearchRange.Cells.Count)
    Set ws = SearchRange.Parent

    For Each Letter In SearchRange
        i = i + 1
        LetterArray(i) = Letter.Value2
        RangeArray(i) = Letter.Address
    Next

    StringPosition = WorksheetFunction.RoundUp((InStr(1, Join(LetterArray, vbNullString), SearchString) / CharacterLength), 0)
    If StringPosition <= 0 Then Exit Sub
    LastSearchIndex = WorksheetFunction.RoundUp((Len(SearchString) / CharacterLength), 0) + StringPosition - 1

    For i = StringPosition To LastSearchIndex
        If SelectedRng Is Nothing Then
            Set SelectedRng = ws.Range(RangeArray(i))
        Else
            Set SelectedRng = Union(SelectedRng, ws.Range(RangeArray(i)))
        End If
    Next

    SelectedRng.Select
End Sub

Sub SelectIt()
    Dim rng As Range
    Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:D4")

    FindWord rng, "developed", 2
End Sub