CODEWITHSUNDEEP
excelvbastringrange
Ger Cas
Ger Cas

Reputation: 2298

Look for substring within Excel range VBA

I have an input text string in a range (from A1 to AV1), each letter in one cell. The string is

From A1 to AV1 look like this

  | 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

I want to be able to search for a substring and if found, select the range where the substring is present.

My current code below it works if the input text string is in the same row, but I'm stuck in how to do if the string is in different rows, for example if the same input text string is in range A1:O4 and I want to search the substring "developed" which begins in N2 and ends in 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

From A1 to O4 look like this

  | 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

Thanks for any help

Update

Thanks both. It works in both solutions. My last issue, I tried the same when each cell contains 2 letters, May you help me to select the range in this case too?

For example the stringToSearch = "developed" and data is from range 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

Upvotes: 0

Views: 1006

Answers (2)

Ryan Wildry
Ryan Wildry

Reputation: 5677

I made this ask into a little subroutine that will take a SearchRange and SearchString as parameters.

The subroutine will select the cells where the first match was found. It should be easy to switch this around if you wanted to return the Range object instead.

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

Edit

Updated this to handle 2 or more characters in one cell. This should work for up to N characters, however I only briefly tested this out. I hope it helps. I'll leave the other method for posterity.

I should mention this revised method does assume all cells have the same number of characters in them. If that isn't true, it likely won't work.

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

Upvotes: 1

Storax
Storax

Reputation: 12167

I modified your code based on the information that we have to look 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

Upvotes: 1

Related Questions