I'm a novice with Excel VBA and what I need to do is take a few cells in a column that contain a name and a phone number and cut the phone number out of that cell and paste it in another column, so I'll have one cell with the name and another with the number.
For some reason my program goes into an infinite loop.
I'm pretty sure it's caused by sLen = sLen - 1 & j = j - 1 but I don't know how to solve it.
Sub loop_macro()
Dim myStr As String
Dim i As Integer
For i = 5 To 15
myStr = movePhone(Cells(i, 2), i)
Cells(i, 5) = myStr
Next i
End Sub
Function movePhone(s As String, rowNum As Integer) As String
Dim retval As String // This is the return string to be copied to column 5
Dim j As Integer // Counter for character position.
Dim sLen As Integer
retval = ""
sLen = Len(s)
For j = 1 To sLen
If Mid(s, j, 1) >= "0" And Mid(s, j, 1) <= "9" Then
retval = retval + Mid(s, j, 1)
Cells(rowNum, 2) = Mid(Cells(rowNum, 2), j, 1) // remove digit from cell
sLen = sLen - 1
j = j - 1
ElseIf Mid(s, j, 1) = "-" Then
retval = retval + Mid(s, j, 1)
Cells(rowNum, 2) = Mid(Cells(rowNum, 2), j, 1) // remove "-" char from cell
sLen = sLen - 1
j = j - 1
End If
Next
movePhone = retval
End Function
Instead of messing around so much with manipulating J so you can go left to right go right to left like so:
for j = sLen to 1 step -1
Now you can ommit the line j=j-1 and it will no longer give you this problem.
Always start at the end and work your way to the start when removing things from strings or even data sets, it's much easier than manipulating the variable you are looping on.
In this instance you should consider using Regexp (Regular Expressions) I have not used them before but they will find number strings within strings (and so much more if you want). Search SO for regexp and you will find heaps of code to help you out.
Related
At first glance, a mixture of mid and len (to remove the curly brackets) and text split would achieve this. However, this does not deal with edge cases where a semicolon or comma is present in an individual element. See the example below.
Let A1=1
Let B1="Semicolon ; in me"
Let A2="Comma, in me"
let B2=4
ARRAYTOTEXT(A1:B2,1)={1,"Semicolon ; in me";"Comma , in me",4} = (C)
ARAYTOTEXT_INV(C) = Spilled range identical to A1:B2
Now using a text split of (C) would find the semicolons and commas within the speech marks and split the text too much. I think I need some use of regex to get the desired result.
The inverse function will be applied to many such ranges so needs to be optimal. The answer needs to also be able to deal with numbers and blank values adequately.
Edit: needs to be able to solve for the below cases as well as normal text:
Numbers that don't have speech marks.
Blanks that are not surrounded by quotation marks.
Sets of sets (which is less likely to happen granted) such as
{"{"a,"," b,";" a,"," b,"}","{"c,"," d,";"c,"," d,"}"}
Edge cases {",",";"), you can imagine an element being the formula
"=FIND(",",a1)" for example.
In the image below you can use ARRAYTOTEXT(B3:C4,1) to get to the value in B7. I want a function that can be placed in B10 (to spill into B10:C11) to give me the original values back i.e. the inverse of ARRAYTOTEXT.
See Excel Example
This is actually not so simple at all. But maybe try:
Formula in A3:
=DROP(DROP(REDUCE(0,MID(A1,SEQUENCE(LEN(A1)),1),LAMBDA(a,b,TOCOL(LET(x,TAKE(a,1),IF(b="""",VSTACK(NOT(x),DROP(a,1)),IF(x+ISNUMBER(--b),VSTACK(DROP(a,-1),TAKE(a,-1)&b),VSTACK(a,"")))),3))),1),-1)
I don't think this will tick your edge-cases.
I had a crack at my own problem. This seems to work for all cases. Can anyone make this more efficient?
Function TEXTTOARRAY(inarr As String)
Dim nDbleQuote As Long
Dim charLng As String
Dim BrkElum() As Long
Dim lenArr As Long
Dim nCol As Long, nRow As Long, nElum As Long
Dim iLng As Long, iRows As Long, iCols As Long, iElum As Long
Dim RowSep As String, ColSep As String
RowSep = Application.International(xlRowSeparator)
ColSep = Application.International(xlColumnSeparator)
'Remove curly brackets
Dim Arr As String: Arr = Mid$(inarr, 2, Len(inarr) - 2)
ReDim BrkElum(1 To 1): BrkElum(1) = 0
nElum = 1
nRow = 1
nCol = 1
lenArr = Len(Arr)
'Iterate through string and find break points
For iLng = 1 To lenArr
charLng = Mid$(Arr, iLng, 1)
If charLng = Chr(34) Then nDbleQuote = nDbleQuote + 1
If WorksheetFunction.IsEven(nDbleQuote) Then
If charLng = ColSep Then
If nRow = 1 Then nCol = nCol + 1
nElum = nElum + 1
ReDim Preserve BrkElum(1 To nElum)
BrkElum(nElum) = iLng
ElseIf charLng = RowSep Then
nRow = nRow + 1
nElum = nElum + 1
ReDim Preserve BrkElum(1 To nElum)
BrkElum(nElum) = iLng
End If
End If
Next iLng
ReDim Preserve BrkElum(1 To nElum + 1)
BrkElum(nElum + 1) = lenArr + 1
'Create array
Dim ArrOut() As Variant
ReDim ArrOut(1 To nRow, 1 To nCol)
For iRows = 1 To nRow
For iCols = 1 To nCol
iElum = (iRows - 1) * nCol + iCols
ArrOut(iRows, iCols) = Mid$(Arr, BrkElum(iElum) + 1, BrkElum(iElum + 1) - BrkElum(iElum) - 1)
If Left$(ArrOut(iRows, iCols), 1) = Chr(34) Then 'Remove outside quotes and replace internal double double quotes with single double quotes
ArrOut(iRows, iCols) = Replace(Mid$(ArrOut(iRows, iCols), 2, Len(ArrOut(iRows, iCols)) - 2), Chr(34) & Chr(34), Chr(34))
ElseIf IsNumeric(ArrOut(iRows, iCols)) Then 'Check if numeric and if so change from text to number
ArrOut(iRows, iCols) = CDbl(ArrOut(iRows, iCols))
End If
Next iCols
Next iRows
TEXTTOARRAY = ArrOut
End Function
You can see in the image linked below the original range in B4:D6.
You can see in B8 ARRAYTOTEXT(B4:D6,1).
You can see in B10:B12 TEXTTOARRAY(B8) (The desired function).
You can see in B14:D16 that all cells in B4:D6=B10:D12.
How it has worked out
Based on the observation that typing a formula ={1,"Semicolon ; in me";"Comma , in me",4} produces the desired result
this can be done as a UDF using Evaluate, and sensitive to the data type of the input
Function TextToArray(r As Variant) As Variant
If TypeOf r Is Range Then
TextToArray = Application.Evaluate(r.Value2)
Else
TextToArray = Application.Evaluate(r)
End If
End Function
Regarding incomplete input (eg {"a",}) to use this you'd have to preprocess the input to add missing elements (eg an empty string ""). But if you do that you might as well just just process the whole string.
Note that this answer is based on your input string being a valid formula. {"a",} is not a valid formula.
In Excel when we try to find some phrase we can put asterisk * inside as any other character. But how to do it inside VBA macro? For example below;
I want to find the secName by searching the value of firName with asterisk but id doesn't work. I suppose the problem is that VBA thinks that i want to find exactly * as normal character instead of anything.
Dim firName, secName As String
firName = "Da*"
secName = "Daniel"
search = InStr(1, secName, firName, vbTextCompare)
MsgBox (search)
Is it possible to use asterisk * in the way I described?
You can either do a FuzzySearch like: Matching similar but not exact text strings in Excel VBA projects, …
… or you can use the The Levenshtein Distance to find out how similar 2 strings are which is probably more accurate but needs O(n*m) time for calculation. So don't use it on very long strings.
Function Levenshtein(str1 As String, str2 As String) As Long
Dim arrLev As Variant, intLen1 As Long, intLen2 As Long, i As Long
Dim j As Long, arrStr1 As Variant, arrStr2 As Variant, intMini As Long
intLen1 = Len(str1)
ReDim arrStr1(intLen1 + 1)
intLen2 = Len(str2)
ReDim arrStr2(intLen2 + 1)
ReDim arrLev(intLen1 + 1, intLen2 + 1)
arrLev(0, 0) = 0
For i = 1 To intLen1
arrLev(i, 0) = i
arrStr1(i) = Mid(str1, i, 1)
Next i
For j = 1 To intLen2
arrLev(0, j) = j
arrStr2(j) = Mid(str2, j, 1)
Next j
For j = 1 To intLen2
For i = 1 To intLen1
If arrStr1(i) = arrStr2(j) Then
arrLev(i, j) = arrLev(i - 1, j - 1)
Else
intMini = arrLev(i - 1, j) 'deletion
If intMini > arrLev(i, j - 1) Then intMini = arrLev(i, j - 1) 'insertion
If intMini > arrLev(i - 1, j - 1) Then intMini = arrLev(i - 1, j - 1) 'deletion
arrLev(i, j) = intMini + 1
End If
Next i
Next j
Levenshtein = arrLev(intLen1, intLen2)
End Function
The smaller the returned number is the more similar are the strings.
For example:
Debug.Print Levenshtein("OFFICE CLUB, S.A.", "OFFICE CLUB SA") 'returns 3
Debug.Print Levenshtein("OFFICE CLUB, S.A.", "OFFICE CLUB S.A.") 'returns 1
The second strings are more similar than the first ones.
I have a columns of strings as follows. How can I put the symbol '<' in between the characters ?
'ABCDE'
'BCG'
'ABCD'
The expected output should be:
A<B<C<D<E
B<C<G
A<B<C<D
=concatenate(left(A1,1),"<",mid(A1,2,1),"<",mid(A1,3,1),(if(len(A1)>3,"<"&mid(A1,4,1)&if(len(A1)>4,"<"&mid(A1,5,1),""),"")))
Will do what you want for values up to 5 letters, and as few as 3 letters. Otherwise you can change it.
Basically it adds a "<" between the first 3 letters and then checks whether the string is longer than 3 letters and if so, adds more "<" characters. If this needs to be more dynamic it's far easier in vba.
A manual, one-off, no-VBA approach would be:
use the Text to Columns tool with Fixed Width and place the markers after each character.
then use a formula like this to append values and separator
The formula could look like this if your values are in row 1
=A1&IF(LEN(B1)>0,">"&B1,"")&IF(LEN(C1)>0,">"&C1,"")&IF(LEN(D1)>0,">"&D1,"")&IF(LEN(E1)>0,">"&E1,"")
Adjust formula to suit the maximum number of characters in a cell.
Such things are not for formulas...
As you tag question as Excel-VBA too, so:
'''''''
Private Sub sb_Test_fp_AddSym()
Debug.Print fp_AddSym("abncd", "<")
End Sub
Public Function fp_AddSym(pStr$, pSym$) As String
Dim i&, j&, iLB&, iUBs&, iUBt&
Dim tSrc() As Byte, tTgt() As Byte, tSym As Byte
tSrc = pStr
tSym = Asc(pSym)
iLB = LBound(tSrc)
iUBs = UBound(tSrc)
iUBt = iUBs * 2 + 3
ReDim tTgt(iLB To iUBt)
For i = iLB To iUBs Step 2
j = i * 2
tTgt(j) = tSrc(i)
tTgt(j + 1) = tSrc(i + 1)
tTgt(j + 2) = tSym
tTgt(j + 3) = 0
Next
ReDim Preserve tTgt(iLB To (iUBt - 4))
Debug.Print tTgt
Stop
fp_AddSym = tTgt
End Function
'''
This worked for me:
Sub SymbolInsert()
Dim cl As Range, temp As String
For Each cl In Range("A1:A3") '~~~> Define your range here
For i = 1 To Len(cl)
temp = temp & Mid(cl, i, 1) & "<"
Next i
cl = IIf(VBA.Right$(temp, 1) = "<", VBA.Left$(temp, Len(temp) - 1), temp)
temp = vbNullString
Next cl
End Sub
It can probably be done with Excel formula for any length, but here is the shortest VBA solution
For Each c In Range("A:A").SpecialCells(xlCellTypeConstants)
c.Value2 = Replace( Left$( StrConv( c, vbUnicode), Len(c) * 2 - 1), vbNullChar, "<")
Next
What it does: I have a section of code which finds a substring TL in a cell, and forces the numbers following it to be of length 6 by adding or deleting 0s immediately following "TL-". (ie TL-00072 -> TL-000072, TL-034 -> TL-000034, TL-000000789 -> TL-000789)
What I want it to do: However, sometimes there are multiple TL values in one cell. I need to find if there is a second occurance of TL, and, if yes, delete that second occurance and everything following it.
Example:
Start: Output:
TL-000789 TL-000187 TL-000773 -> TL-000789
TL-000689 TL -000787 -> TL-000689
TL-000982 TL - 980819 -> TL-000982
This is the attempt at code I have been working on (incorrect and not working) using split (maybe trim would work too?) that would find the second occurence of TL and delete everything after it. Full working code below that.
CURRENT ATTEMPT AT CODE
Dim splitValues As Variant
If Str(str, "TL" + 1) 'do not know how to get SECOND occurrence
splitValues = Split(theValue, "TL")
theValue = splitValues(0)
End If
WORKING CODE
[will add new code to beginning] (explanation at top of question)
NOTE: StartSht is the workbook where the values are as well as the code.
All values being altered are in column "C"
'force length of TL/CT to be 6/4 numbers long, eliminate spaces
Dim str As String, ret As String, tmp As String, j As Integer, k As Integer
For k = 2 To StartSht.Range("C2").End(xlDown).Row
ret = ""
str = StartSht.Range("C" & k).Value
'for TL numbers
''''''''''''''new code goes here''''''''''''''''''
If InStr(str, "TL") > 0 Then
For j = 1 To Len(str)
tmp = Mid(str, j, 1)
If IsNumeric(tmp) Then ret = ret + tmp
Next j
'force to 6 numbers if too short; add 0s immediately after "TL-"
For j = Len(ret) + 1 To 6
ret = "0" & ret
Next j
'force to 6 numbers if too long; eliminate 0s immediately after "TL-"
If Len(ret) > 6 Then
Debug.Print Len(ret)
For j = Len(ret) To 7 Step -1
If Mid(ret, 1, 1) = "0" Then
ret = Right(ret, j - 1)
End If
Next j
End If
'eliminate superfluous spaces around "TL-"
ret = "TL-" & ret
StartSht.Range("C" & k).Value = ret
'for CT numbers
ElseIf InStr(str, "CT") > 0 Then
For j = 1 To Len(str)
tmp = Mid(str, j, 1)
If IsNumeric(tmp) Then ret = ret + tmp
Next j
'force to 4 numbers if too short; add 0s immediately after "CT-"
For j = Len(ret) + 1 To 4
ret = "0" & ret
Next j
'force to 4 numbers if too long; eliminate 0s immediately after "CT-"
If Len(ret) > 4 Then
Debug.Print Len(ret)
For j = Len(ret) To 5 Step -1
If Mid(ret, 1, 1) = "0" Then
ret = Right(ret, j - 1)
End If
Next j
End If
'eliminate superfluous spaces around "CT-"
ret = "CT-" & ret
StartSht.Range("C" & k).Value = ret
End If
Next k
It looks like you could just redefine str if you find a second "TL". After the line:
If InStr(str, "TL") > 0 Then
add another IF statement:
If InStr(3, str, "TL") > 0 Then str = Mid(str, 1, Instr(3, str, "TL") - 2)
Then continue with the rest of your code using the new str.
So, I have this Function which will quickly return the Levenshtein Distance between two Strings:
Function Levenshtein(ByVal string1 As String, ByVal string2 As String) As Long
Dim i As Long, j As Long
Dim string1_length As Long
Dim string2_length As Long
Dim distance() As Long
string1_length = Len(string1)
string2_length = Len(string2)
ReDim distance(string1_length, string2_length)
For i = 0 To string1_length
distance(i, 0) = i
Next
For j = 0 To string2_length
distance(0, j) = j
Next
For i = 1 To string1_length
For j = 1 To string2_length
If Asc(Mid$(string1, i, 1)) = Asc(Mid$(string2, j, 1)) Then
distance(i, j) = distance(i - 1, j - 1)
Else
distance(i, j) = Application.WorksheetFunction.Min _
(distance(i - 1, j) + 1, _
distance(i, j - 1) + 1, _
distance(i - 1, j - 1) + 1)
End If
Next
Next
Levenshtein = distance(string1_length, string2_length)
End Function
I want to perform a fast comparison between all cells in the "A" column and return which ones have a "small" Levenshtein distance. How would I make all these comparisons?
Do you want to find which combinations of strings have small levenshtein distances or just overall how similar/disimilar each string is with all the other strings?
If it is the former this should work fine:
You just copy and paste transposed values to create all those headers(as Dale commented). You can use the conditional formatting to highlight the lowest results.
Or if you want the actual strings to return you should be able to use this:
=IF(AND(Levenshtein($A28,B$27)>0,Levenshtein($A28,B$27)<=3),$A28&"/"&B$27,"")
Just copy and paste unique values if you want the returned combinations in a single column.
Good Luck.