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
Related
I would like to split my string in Excel between the address and postcode. I want to keep the postcode separately.
By selecting the option - Data -Text to column - delimited - comma-separated - the whole string is divided by 4 pieces, as 3 commas occur.
1 - 21 Willow Court, 1192 Christchurch Road, Bournemouth, BH7 6EG
I found, that it can be done in VBA Excel.
There are a few approaches below:
Excel VBA- remove part of the string
https://www.thespreadsheetguru.com/the-code-vault/2014/2/28/remove-last-character-from-string
How to delete last character in a string with VBA?
Removing last characters vba
How to i remove a text after '*' or '-' character using VBA in excel?
I prepared the VBA code like below:
Sub Textremove()
Dim c As Variant
For Each c In Range("D1:D100")
c.Value = Left(c.Value, InStr(c.Value, ",") - 1)
Next c
End Sub
I am receiving only:
1 - 21 Willow Court
and the error Invalid procedure call or argument, debugging the following line:
c.Value = Left(c.Value, InStr(c.Value, ",") - 1)
So the breakdown occurs after the first comma instead of the last one.
I found an answer regarding this error:
invalid procedure call or argument left
And when my code looks like this:
Sub Textremove()
Dim c As Variant
For Each c In Range("D1:D100")
If InStr(c.Value, ",") > 0 Then
c.Value = Left(c.Value, InStr(c.Value, ",") - 1)
End If
Next c
End Sub
Then error doesn't occur anymore, but I am still getting the stuff until the first comma instead of the last one.
When I change the code a bit:
Sub Textremove()
Dim c As Variant
For Each c In Range("D1:D100")
If InStr(c.Value, ",") > 0 Then
c.Value = Right(c.Value, InStr(c.Value, ","))
End If
Next c
End Sub
I am getting 2 sentences from the right
Bournemouth, BH7 6EG
which are not fixed and change depending on the total length of the string.
How can I receive the string till the last comma instead of the first one?
How can I split the whole string between the address and postcode separately?
A good example is here:
https://trumpexcel.com/vba-split-function/
Sub CommaSeparator()
Dim TextStrng As String
Dim Result() As String
Dim DisplayText As String
Dim i As Long
TextStrng = Sheets("Final").Range("D1")
Result = Split(TextStrng, ",", 1)
For i = LBound(Result()) To UBound(Result())
DisplayText = DisplayText & Result(i) & vbNewLine
Next i
MsgBox DisplayText
End Sub
It admittedly splits the whole address, but it is counted still from the first comma.
In my case that works. I just added the UBound(Result())-1.
Sub CommaSeparator()
Dim TextStrng As String
Dim Result() As String
Dim DisplayText As String
Dim i As Long
TextStrng = Sheets("Final").Range("D1")
Result = Split(TextStrng, ",")
For i = LBound(Result()) To UBound(Result()) - 1
DisplayText = DisplayText & Result(i) & vbNewLine
Next i
MsgBox DisplayText
End Sub
In case you need VBA, maybe use:
Sub Test()
Dim str As String
Dim arr As Variant
str = "1 - 21 Willow Court, 1192 Christchurch Road, Bournemouth, BH7 6EG"
arr = Split(StrReverse(Replace(StrReverse(str), ",", "|", , 1)), "|")
End Sub
I reversed the whole string through StrReverse(), then used Replace() to replace only the 1st comma with a pipe-symbol (note the use of the Count parameter), reversed the string back and used a Split(). This returns:
An alternative would be to make use of the worksheetfunction REPLACE() instead of the VBA function which inconveniently is called the same.
Sub Test()
Dim str As String: str = "1 - 21 Willow Court, 1192 Christchurch Road, Bournemouth, BH7 6EG"
Dim arr As Variant
arr = Split(Application.Replace(str, InStrRev(str, ","), 1, "|"), "|")
End Sub
The main difference is now that Application.Replace does take a parameter to start the replacement at without cutting of the preceding text. We can find our starting position using InstrRev().
Both options return:
Just for fun I'll chuck in an regex solution:
Sub Test()
Dim str As String: str = "1 - 21 Willow Court, 1192 Christchurch Road, Bournemouth, BH7 6EG"
Dim arr As Variant
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "^.*(?=,)|[^,]+$"
Set arr = .Execute(str)
End With
End Sub
This will return a "MatchCollectionObject" where you can call your results through: arr(0) and arr(1). A little bit of explaination of the pattern:
^ - Start string anchor.
.* - A greedy match of anything other than newline up to:
(?=,) - Positive lookahead for a comma.
| - Or match:
[^,]$ - Anything other than comma up to the end string anchor.
See the online demo
Use the array returned by Split to rebuild the string however you like it e.g.:
Sub DoSplit()
s = "1 - 21 Willow Court, 1192 Christchurch Road, Bournemouth, BH7 6EG"
a = Split(s, ",")
finalString = a(0) & a(1) & a(2) & ", " & a(3)
MsgBox finalString
End Sub
I have sorted this in a different, 2-steps way.
First of all, I split a whole address, by using the formula from here:
Split address field in Excel
Sub Split()
Dim MyArray() As String
Dim Ws As Worksheet
Dim lRow As Long, i As Long, j As Long, c As Long
'~~> Change this to the relevant sheet name
Set Ws = ThisWorkbook.Sheets("Final")
With Ws
lRow = .Range("E" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
If InStr(1, .Range("E" & i).Value, ",", vbTextCompare) Then
MyArray = Split(.Range("E" & i).Value, ",")
c = 1
For j = 0 To UBound(MyArray)
.Cells(i, c).Value = MyArray(j)
c = c + 1
Next j
End If
Next i
End With
End Sub
and next, I merged what I needed by using this hint:
Excel macro to concatenate one row at a time to end of file
Sub Merge()
Dim LastRow As Long
Dim Ws As Worksheet
Set Ws = Sheets("Final")
LastRow = Ws.Range("A" & Ws.Rows.Count).End(xlUp).Row
'~~> If your range doesn't have a header
Ws.Range("H1:H" & LastRow).Formula = "=A1&B1&C1"
'~~> If it does then
Ws.Range("H2:H" & LastRow).Formula = "=A2&B2&C2"
End Sub
and finally, I received:
1 - 10 Haviland Court 104 Haviland Road Bournemouth
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
I am trying to use wildcards in a formula to count cells in a table column which contain text and not ""
I tried the following methods:
String comparison
Dim g As Integer
g = Application.WorksheetFunction.CountIf(ThisWorkbook.Worksheets("ws1").ListObjects("Table1").ListColumns("ColumnA").DataBodyRange, ""*?"")
Using a tilde failed:
Dim g As Integer
g = Application.WorksheetFunction.CountIf(ThisWorkbook.Worksheets("ws1").ListObjects("Table1").ListColumns("ColumnA").DataBodyRange, ""~*?"")
Using ASCII characters below returned 0:
g = Application.WorksheetFunction.CountIf(ThisWorkbook.Worksheets("ws1").ListObjects("Table1").ListColumns("Column1").DataBodyRange, Chr(34) & Chr(63) & Chr(42) & Chr(34))
Tried and tested:
Public Function not_qt(ByVal rng As Range) As Integer
Dim cell As Range
Dim counter As Integer: counter = 0
For Each cell In rng
If Not IsEmpty(cell) Then
If Not cell Like Chr(34) & "*" & Chr(34) Then
counter = counter + 1
'cell.Offset(0, 1) = counter '<- Only for illustration purposes
End If
End If
Next cell
not_qt = counter
End Function
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)
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: