Ищите подстроку в диапазоне 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 = "развитый" и данные из диапазона 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

Я превратил этот запрос в небольшую подпрограмму, которая будет принимать 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

Answer 2

Я изменил ваш код, основываясь на информации, которую мы должны искать в диапазоне («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