VBA splitting cell by new line in a loop - excel

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

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
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

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:

Related

Using Evaluate with string variable not with range object

I have a line of code that returns 1d array based on a value in range A1. Example suppose there's a value 6548102 in A1 and I used this line x = [TRANSPOSE(MID(A1,1+len(A1)-ROW(OFFSET(A1,,,LEN(A1))),1))] this line returned a 1d array of each digit in A1
This is my try
Sub Demo()
Dim x
Dim s As String
s = "6548102"
'x = [TRANSPOSE(MID(A1,1+len(A1)-ROW(OFFSET(A1,,,LEN(A1))),1))]
x = [TRANSPOSE(MID(" & s & ",1+LEN(" & s & ")-ROW(OFFSET(" & s & ",,,LEN(" & s & "))),1))]
Stop
End Sub
I tried to replace A1 with the string variable but it seems this trick doesn't work.
Simply I need to deal with a string not a range with the same technique.
It would be simple to just use VBA:
Sub ReverseDemo()
dim s as string
s = "6548102"
dim x() as variant
redim x(0 to len(s) - 1) as variant
dim k as long
k = 0
dim i as long
for i = len(s) to 1 step -1
x(k) = mid(s,i,1)
k = k + 1
Next i
'Do something with x
End Sub
Split with Evaluate
Instead of using [] use Evaluate, and don't replace A1 in the OFFSET part of the formula with the value you want to split.
Sub Demo()
Dim x
Dim s As String
s = 123
x = Evaluate("TRANSPOSE(MID(""" & s & """,ROW(OFFSET(A1,,,LEN(""" & s & """))),1))")
Debug.Print Join(x, "-")
End Sub
Strings
If you actually want to split a string you would need to add double quotes throughout.
Sub StringDemo()
Dim x
Dim s As String
s = "Yassser"
x = Evaluate("TRANSPOSE(MID(""" & s & """,ROW(OFFSET(A1,,,LEN(""" & s & """))),1))")
Debug.Print Join(x, "-")
End Sub
Actually, you probably want to use the second code as it will work for both strings and numbers.
Reverse
If, for some reason you wanted the characters/digits in reverse order you can use this.
Sub ReverseDemo()
Dim x
Dim s As String
s = "Reverse"
x = Evaluate("TRANSPOSE(MID(""" & s & """,1+LEN(""" & s & """)-ROW(OFFSET(A1,,,LEN(""" & s & """))),1))")
Debug.Print Join(x, "-")
End Sub

Search sentence for all values in a list of values and return all found into adjacent cell

I am looking to search for values from a list in Sheet1 in each cell of column C on sheet2 to be separated by commas.
Sheet1 has a list of names:
Sheet 2 has a set of sentences in column C. The output in column D should be the names in Sheet1.
I have searched but haven't found a solution.
I don't have any code to show that has been effective in this regard but I did come across a function that seemed promising but, since I don't know what would surround the name per cell it isn't quite what I need.
Function RegexExtract(ByVal text As String, _
ByVal extract_what As String, _
Optional separator As String = ", ") As String
Dim allMatches As Object
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
Dim i As Long, j As Long
Dim result As String
RE.Pattern = extract_what
RE.Global = True
Set allMatches = RE.Execute(text)
For i = 0 To allMatches.Count - 1
For j = 0 To allMatches.Item(i).submatches.Count - 1
result = result & (separator & allMatches.Item(i).submatches.Item(j))
Next
Next
If Len(result) <> 0 Then
result = Right$(result, Len(result) - Len(separator))
End If
RegexExtract = result
End Function
Using regexp Test:
Function CheckList(ByVal text As String, list As Range) As String
Static RE As Object
Dim arr, sep, r As Long, result As String, v
If RE Is Nothing Then Set RE = CreateObject("vbscript.regexp")
If Len(text) > 0 Then
arr = list.Value
'check each name
For r = 1 To UBound(arr, 1)
v = arr(r, 1)
If Len(v) > 0 Then
RE.Pattern = "\b" & v & "\b" '<< whole word only
If RE.test(text) Then
result = result & sep & v
sep = ", " 'populate the separator
End If
End If
Next r
End If
CheckList = result
End Function
You can use a Dictionary object to check each string against the NameList, assuming that the names in the sample string do not have punctuation.
If they do, this method can still be used, but would require some modification. For example, one could replace all of the punctuation with spaces; or do something else depending on how complex things might be.
eg:
Option Explicit
Function ckNameList(str As String, nameList As Range) As String
Dim D As Dictionary
Dim vNames, I As Long, V, W
Dim sOut As String
vNames = nameList
Set D = CreateObject("Scripting.Dictionary")
D.CompareMode = TextCompare
For I = 1 To UBound(vNames)
If Not D.Exists(vNames(I, 1)) Then _
D.Add vNames(I, 1), vNames(I, 1)
Next I
V = Split(str, " ")
sOut = ""
For Each W In V
If D.Exists(W) Then _
sOut = sOut & ", " & W
Next W
ckNameList = Mid(sOut, 3)
End Function
Scott showed how to use TEXTJOIN, when you don't have access to this function. Your best best might be VBA. We could emulate some sort of TEXTJOIN, possibly like so:
Function ExtractNames(nms As Range, str As Range) As String
ExtractNames = Join(Filter(Evaluate("TRANSPOSE(IF(ISNUMBER(SEARCH(" & nms.Address & "," & str.Address & "))," & nms.Address & ",""|""))"), "|", False), ", ")
End Function
Called in D2 like: =ExtractNames($A$2:$A$7,C2) and dragged down. Downside of this Evalate method is that it's making use of an array formula, however the native TEXTJOIN would have been so too. Plusside is that it's avoiding iteration.
EDIT
As #TimWilliams correctly stated, this might end up confusing substrings that hold part of what we are looking for, e.g. > Paul in Pauline.
I also realized that to overcome this, we need to substitute special characters. I've rewritten my function to the below:
Function ExtractNames(nms As Range, str As Range) As String
Dim chr() As Variant, arr As Variant
'Create an array of characters to ignore
chr = Array("!", ",", ".", "?")
'Get initial array of all characters, with specified characters in chr substituted for pipe symbol
arr = Evaluate("TRANSPOSE(IF(ISNUMBER(MATCH(MID(" & str.Address & ",ROW(A1:A" & Len(str.Value) & "),1),{""" & Join(chr, """,""") & """},0)),""|"",MID(" & str.Address & ",ROW(A1:A" & Len(str.Value) & "),1)))")
'Get array of words used to check against names without any specified characters
arr = Split(Join(Filter(arr, "|", False), ""), " ")
'Check which names occur in arr
For Each cl In nms
If IsNumeric(Application.Match(cl.Value, arr, 0)) Then
If ExtractNames = "" Then
ExtractNames = cl.Value
Else
ExtractNames = Join(Array(ExtractNames, cl.Value), ", ")
End If
End If
Next cl
End Function
As you can tell, it's possible still, but my conclusion and recommendation would be to go with RegEx. #TimWilliams has a great answer explaining this, which I slightly adapted to prevent an extra iteration:
Function ExtractNames(nms As Range, str As Range) As String
Dim regex As Object: Set regex = CreateObject("VBScript.RegExp")
Dim arr() As Variant: arr = Application.Transpose(nms.Value)
Dim del As String
regex.Pattern = "\b(?:" & Join(arr, "|") & ")\b"
regex.Global = True
regex.Ignorecase = True
Set hits = regex.Execute(str.Value)
For Each hit In hits
ExtractNames = ExtractNames & del & hit
del = ", "
Next hit
End Function
Or even without iteration:
Function ExtractNames(nms As Range, str As Range) As String
Dim regex As Object: Set regex = CreateObject("VBScript.RegExp")
Dim arr() As Variant: arr = Application.Transpose(nms.Value)
Dim del As String
regex.Global = True
regex.Ignorecase = True
'Perform 1st replace on non-alphanumeric characters
regex.Pattern = "[^\w]"
ExtractNames = Application.Trim(regex.Replace(str.Value, " "))
'Perferom 2nd replace on all words that are not in arr
regex.Pattern = "\b(?!" & Join(arr, "|") & ")[\w-]+\b"
ExtractNames = Application.Trim(regex.Replace(ExtractNames, " "))
ExtractNames = Replace(ExtractNames, " ", ", ")
End Function

How to extract Upper case words (with at least two letters)

I need to extract last names, which are allways written upper case, from cells, where is written all the name. The name can have different shapes e.g.:
Jan H. NOVAK
Petr Karel POUZAR
Frantisek Ix GREGOR
I have tried to find some VBAs on the web. I found this one, but it extract also the one letter middle names which are also upper case:
Function UpperWords(str As Variant) As String
Dim i As Integer, sTemp As String, StrTmp As String
For i = 0 To UBound(Split(str, " "))
StrTmp = Split(str, " ")(i)
If UCase(StrTmp) = StrTmp Then sTemp = sTemp & " " & StrTmp
Next i
UpperWords = Trim(sTemp)
End Function
I need to define in the VBA tahat the upper case word which I want to extract has at least two letters.
Thank you for your ideas.
Add the test to the If:
Function UpperWords(str As Variant) As String
Dim i As Integer, sTemp As String, StrTmp As String
For i = 0 To UBound(Split(str, " "))
StrTmp = Split(str, " ")(i)
If UCase(StrTmp) = StrTmp And Len(StrTmp) > 1 Then sTemp = sTemp & " " & StrTmp
Next i
UpperWords = Trim(sTemp)
End Function
If what you want is to extract last names, then you can use a formula/function to do just that. Capitalization would seem to be irrelevant.
worksheet formula
=TRIM(RIGHT(SUBSTITUTE(TRIM(A1)," ",REPT(" ",99)),99))
UDF
Function lastName(S As String) As String
lastName = Mid(S, InStrRev(Trim(S), " ") + 1)
End Function
Dim regEx As Object
Dim allMatches As Object
Dim Surname As Variant
Dim rng As Range
Dim cell As Range
Dim m As Match
Set rng = ThisWorkbook.Worksheets("Sheet2").Range("A1:A4")
For Each cell In rng
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.IgnoreCase = True
.MultiLine = False
.Pattern = "\s([A-Z]+)$"
.Global = True
End With
Set allMatches = regEx.Execute(cell.Value)
For Each m In allMatches
Surname = m.SubMatches(0)
Debug.Print Surname
Next
Next cell

cell.Value not retrieving the carriage returns in the cell

My Excel cells have carriage return(s) \ line feeds, but when reading into cell.value, the carriage returns disappear. Is there a way to handle this so that I can determine where the line breaks were (without modifying my source Excel sheet data)?
In the code below (at the bottom of this thread), I would have expected the ProductText variable to be set as:
Orange<CR>
Red<CR>
Yellow<CR>
where <cr> means carriage return.
I can confirm that the line-feeds are present when I copy from an Excel cell into Notepad.
But in VBA, ProductText is populated as: "Orange Red Yellow" and the carriage returns are gone.
'YOU MAY SKIP TO THE ******************************************* for the purposes of this post
Public Sub ProcessCharmMingFile(Excel_UNC_Path As String)
Dim src As Workbook
Dim ProdPushWorkbook As Workbook
Set ProdPushWorkbook = ActiveWorkbook
Set src = Workbooks.Open(Excel_UNC_Path, True, True)
Dim c As Range
Dim r As Range
Dim LastRow As Long
Dim Text As String
src.Sheets("Table 1").Activate
src.ActiveSheet.Range("A1").Select
LastRow = src.ActiveSheet.Range("A30000").End(xlUp).Row
Text = LastRow
Text = "A1:T" + CStr(Text)
Set r = Range(Text)
Dim i As Integer
For i = 1 To MaxItems
PONumber(i) = ""
Next
Dim PageCounter As Integer
PageCounter = 0
RecordCounter = 0
Dim ProductText As String
Dim QtyText As String
Dim HeatText As String
'***********************************************************
'***********************************************************
'***********************************************************
For Each c In r
If c.Value = "ALLIED FITTING Product Code" Then
PageCounter = PageCounter + 1
ProductText = c.Offset(1, 0).Value
HeatText = c.Offset(1, 1).Value
QtyText = c.Offset(1, 2).Value
End If
Next
'***********************************************************
'***********************************************************
'***********************************************************
If RecordCounter = 0 Then
Call AbortFileProcessing("No Valid Reoords Dected", False, ProdPushWorkbook)
End If
src.Close
End Sub
The thing is that you need a Line Feed to get the lines to display separately in a cell.
VBA has the appropriate constants for this:
Sub CRLFString()
Dim str As String
str = "hello" & vbCr & "world!"
Range("A1").Value = str 'Reads: "helloworld!" - Wrap Text won't change this.
str = "hello" & vbLf & "world!"
Range("A2").Value = str
str = "hello" & vbCrLf & "world!"
Range("A3").Value = str 'Both of these read
'hello
'world!
End Sub
However, if you would output these strings using Debug.Print all three of them would be on 2 lines as expected.
In short: Add a line feed, otherwise you get the result described in the question.
You can just use Replace on vbCr to do so:
Sub AddLineBreaksAndOutput(str As String)
str = Replace(str, vbCr, vbCrLf)
Range("A4").Value = str
End Sub
Sub Test()
Dim str As String
str = "hello" & vbCr & "world!"
AddLineBreaksAndOutput str
End Sub
Carriage Return Trouble
Out of curiosity what is the code number of the "CR" character. You can get it using this formula: =CODE(MID(A1,7,1)) in Excel (adjust A1 and 7 appropriately).
If this behavior persists you can split the string into an array and concatenate with the appropriate character e.g. Chr(10):
Declare two variables, then after the line ProductText = ... you know what to do.
Dim j As Integer
Dim vntText As Variant
ProductText = c.Offset(1, 0).Value
vntText = Split(ProductText, " ")
For j = 0 To UBound(vntText)
If j > 0 Then
ProductText = ProductText & Chr(10) & vntText(j)
Else
ProductText = vntText(0)
End If
Next
I want to enhance the answer already posted....
You should replace all types of LF's and CR's with vbCRLF, then use that as your splitter.
Here is my code... it can be enhanced further, based on your needs. In my case, it was vbLF that was the culprit, not vbCR. I replaced both, though, with vbCrLF, and then used that as my splitter...
ProductText = Replace(Replace(c.Offset(1, 0).Value, vbCr, vbCrLf), vbLf, vbCrLf)
ProdAry = Split(ProductText, vbCrLf)

Excel 2007 VBA code to automate extracting and storing numeric values from a string with special characters

I have a string which is in A1 of Sheet1 and it refreshes regularly.
it looks like this -
{"rows":[{"advances":637,"declines":836,"unchanged":76,"total":1549}],"success":"true","results":1}
I want to extract numeric values 637 and 836 and 76 and store it in separate columns. The values keeps on changing, like 637 can be sometimes 1200.
I want a VBA code, not an user defined function to automatically extract the numeric data and store it.
I am using this code, but I am not getting anything. What is wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v
End If
Range("=Sheet1!$E$1:$G$1").Copy Destination:=Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1)
Sheets("Updated").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Now
End Sub
While I would be tempted to use standard functions for this you could run a VBA UDF like so
to get the first match from A1 (as a number)
=RegexMatches(A1,1)
the second match
=RegexMatches(A1,2)
and so on
The UDF returns "No Match" where no matches are found, or a message "Less than X matches" if you try to extract a match from a position that doesb't exist
Function RegexMatches(strIn As String, LngPos As Long)
Dim objRegex
Dim objRegexMC
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = ":(\d+),"
If .test(strIn) Then
Set objRegexMC = .Execute(strIn)
If objRegexMC.Count >= LngPos Then
RegexMatches = CLng(objRegexMC(LngPos - 1).submatches(0))
Else
RegexMatches = "Less than " & LngPos & " matches"
End If
Else
RegexMatches = "No Match"
End If
End With
End Function
[Update: added sheet event code]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Set rng1 = Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
'set row1 as first row if it is blank
If rng1.Row = 2 And rng1.Offset(-1, 0) = vbNullString Then Set rng1 = rng1.Offset(-1, 0)
rng1.Resize(1, 3).Value = Range("B1:D1").Value
rng1.Offset(0, -1).Value = Now
End Sub
You can use an instance of the windows script control to parse the text for you:
Sub Tester()
Dim JSON As String
Dim sc As Object
JSON = "{""rows"":[{""advances"":637,""declines"":836," & _
"""unchanged"":76,""total"":1549}]" & _
",""success"":""true"",""results"":1}"
'JSON = ActiveSheet.Range("A1").Value
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.Eval "var o = eval(" & JSON & ")" 'evaluate to an object
Debug.Print "success", sc.Eval("o.success")
Debug.Print "#results", sc.Eval("o.results")
Debug.Print " advances", sc.Eval("o.rows[0].advances")
Debug.Print " declines", sc.Eval("o.rows[0].declines")
Debug.Print " unchanged", sc.Eval("o.rows[0].unchanged")
End Sub
I needed something similar and developed the following code. I have no doubts that it could be made more sophisticated but it provided me with the required result.
Dim cr_ref As String ' Original reference - alpha and numer
Dim new_ref As String ' Resultant numeirc only reference
Dim iAsciiCode As Integer
Dim sCount As Integer ' Length of reference
cr_ref = Trim(Cells(4, 19).Value) ' Get reference from source
sCount = Len(cr_ref)
new_ref = "" ' Start with empty result
For i = 0 To sCount - 1 ' Strip out all except digits
iAsciiCode = Asc(Mid(cr_ref, i + 1, 1)) ' Give me Ascii code
If iAsciiCode >= 48 And iAsciiCode <= 57 Then ' I only want 0-9
new_ref = new_ref & Mid(cr_ref, i + 1, 1) ' Append numeric digit
End If
Next i
' Result is in new_ref
This works:
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v

Resources