babz
babz

Reputation: 479

VBA splitting cell by new line in a loop

New to VBA, trying to create a function that essentially searches a column for certain values. If it finds a hit then it returns a corresponding column, else returns a space. The way the worksheet is formatted, one cell can have multiple values (separated by ALT+ENTER, so each new value is on a separate line).

The code I used currently works but has an issue: Since I am using inStr the code is returning partial matches as well (which I do not want).

Example:
**Column to Search (one cell)**
ABC
AB
B

When I run the code to find AB, it will return hits for both AB and ABC since AB is part of it.

Ideal solution would be to first split the cells based on ALT+ENTER and loop through all values per cell and then return the desired value. But not how the syntax would look.

Current Code

Function newFunc(Search_string As String, Search_in_col As Range, Return_val_col As Range)

Dim i As Long
Dim result As String
Dim mRange As Range
Dim mValue As String

For i = 1 To Search_in_col.Count

    If InStr(1, Search_in_col.Cells(i, 1).Text, Search_string) <> 0 Then
          If (Return_val_col.Cells(i, 1).MergeCells) Then

            Set mRange = Return_val_col.Cells(i, 1).MergeArea
            mValue = mRange.Cells(1).Value

            result = result & mValue & ", "
        Else
            result = result & Return_val_col.Cells(i, 1).Value & ", "
        End If
    End If

Next 

Example: Adding an example to better explain the situation

example

Upvotes: 1

Views: 1640

Answers (2)

Ron Rosenfeld
Ron Rosenfeld

Reputation: 60174

You can use regular expressions which have a word boundary token. The following seems to reproduce what you show in your example:

Option Explicit
'Set reference to Microsoft VBScript Regular Expressions 5.5
Function col_return(lookFor As String, lookIn As Range) As String
    Dim RE As RegExp
    Dim C As Range
    Dim S As String

Set RE = New RegExp
With RE
    .Global = True
    .IgnoreCase = True 'unless you want case sensitive searches
    For Each C In lookIn
        .Pattern = "\b(" & lookFor & ")\b"
        If .Test(C.Text) = True Then
            S = S & "," & C.Offset(0, -1)
        End If
    Next C
End With

col_return = Mid(S, 2)

End Function

I used early binding, which means you set a reference in VBA as noted in the comments.

You can use late-binding and avoid the reference. To do that you would change to the DIM and Set lines for RE to:

DIM RE as Object

Set RE = createobject("vbscript.regexp")

You can read about early vs late-binding by doing an internet search.

The formula I used and the layout is in the screenshot below:

enter image description here

Upvotes: 2

Scott Craner
Scott Craner

Reputation: 152450

you can split the string and loop that.

Function newFunc(Search_string As String, Search_in_col As Range, Return_val_col As Range) As String


    If Search_in_col.Cells.Count <> Return_val_col.Cells.Count Then Exit Function

    Dim sptStr() As String
    sptStr = Split(Search_string, Chr(10))

    Dim srchArr() As Variant
    srchArr = Search_in_col.Value

    Dim RetArr() As Variant
    RetArr = Return_val_col.Value

    Dim i As Long
    For i = LBound(sptStr) To UBound(sptStr)
        Dim j As Long
        For j = LBound(srchArr, 1) To UBound(srchArr, 1)
            If srchArr(j, 1) = sptStr(i) Then
                newFunc = newFunc & RetArr(j, 1) & ", "
            End If
        Next j
    Next i

    newFunc = Left(newFunc, Len(newFunc) - 2)


End Function

enter image description here


EDIT:

As per the new information:

Function newFunc(Search_string As String, Search_in_col As Range, Return_val_col As Range) As String

    Search_string = "|" & Search_string & "|"

    Dim srchArr() As Variant
    srchArr = Search_in_col.Value

    Dim RetArr() As Variant
    RetArr = Return_val_col.Value

    Dim i As Long
    For i = LBound(srchArr, 1) To UBound(srchArr, 1)
        Dim T As String
        T = "|" & Replace(srchArr(i, 1), Chr(10), "|") & "|"

        If InStr(T, Search_string) > 0 Then
              newFunc = newFunc & RetArr(i, 1) & ", "
        End If

    Next i

    newFunc = Left(newFunc, Len(newFunc) - 2)
End Function

enter image description here

Upvotes: 4

Related Questions