what I am currently trying to do is to find and highlight cells that contain simultaneously a certain phrase and (among some other text) a number that is equal or greater than 20 (including numbers with decimals like 25.8332). I tried using FormatConditions, but I wasn't able to make it consider two simultaneous conditions (a phrase and a number). So I decided to use a combination of If and InStr, but I wonder how to fill in the number that is equal or greater than 20?
Select the cells you wish to process and run:
Sub ColorMeYellow()
Dim r As Range, s As String, n As Double
Dim happy As String, CH As String, temp As String
Dim L As Long, i As Long
happy = "happy"
For Each r In Selection
s = r.Value
If InStr(1, s, happy) > 0 Then
L = Len(s)
temp = ""
For i = 1 To L
CH = Mid(s, i, 1)
If CH Like "[0-9]" Or CH = "." Then
temp = temp & CH
End If
Next i
If IsNumeric(temp) Then
If CDbl(temp) > 20 Then
r.Interior.ColorIndex = 6
End If
End If
End If
Next r
End Sub
It will look for cells containing both *"happy" and a number greater than 20.
Related
I'm trying to take a body of text and add line breaks around 80 characters on each line. The issue I'm having is on the last line it's adding an extra line break than would be desired. For instance this string should not have a line break on the second to last line:
Alice was beginning to get very tired of sitting by her sister on the bank, and
of having nothing to do: once or twice she had peeped into the book her sister
was reading, but it had no pictures or conversations in it, and what is the use
of a book, thought Alice without pictures or
conversations?
should look like this (note "conversations" has been moved up):
Alice was beginning to get very tired of sitting by her sister on the bank, and
of having nothing to do: once or twice she had peeped into the book her sister
was reading, but it had no pictures or conversations in it, and what is the use
of a book, thought Alice without pictures or conversations?
Here's the code:
Sub StringChop()
Dim OrigString As String
Dim NewString As String
Dim counter As Long
Dim length As Long
Dim LastSpace As Long
Dim LineBreak As Long
Dim TempString As String
Dim TempNum As Long
OrigString = "Alice was beginning to get very tired of sitting by her sister on the bank, and of having nothing to do: once or twice she had peeped into the book her sister was reading, but it had no pictures or conversations in it, and what is the use of a book, thought Alice without pictures or conversations?"
length = Len(OrigString)
counter = 1
Do While counter < length
'Extract next 80 characters from last position
TempString = Mid(OrigString, counter, 80)
'Determine last space in string
LastSpace = InStrRev(TempString, " ")
'Determine first line break in string
LineBreak = InStr(TempString, vbNewLine)
'If line break exists in sentence...
'only count characters up to line break, and set counter to that amount
Select Case LastSpace 'What to do if there are spaces in sentence
Case Is > 0 'There are spaces in sentence
Select Case LineBreak 'What to do if there are line breaks in sentence
Case Is = 0
'From last counter position,
NewString = NewString & Mid(OrigString, counter, LastSpace) & vbNewLine
counter = counter + LastSpace
Case Is <> 0
NewString = NewString & Mid(OrigString, counter, LineBreak)
counter = counter + LineBreak
End Select
Case Is = 0 'There are no more spaces left in remaining sentence
NewString = NewString & Mid(OrigString, counter)
counter = length
End Select
Loop
Debug.Print NewString
End Sub
Word wrapping is an interesting problem. I wrote the following code once as an experiment. You might find it helpful:
Option Explicit
'Implements a dynamic programming approach to word wrap
'assumes fixed-width font
'a word is defined to be a white-space delimited string which contains no
'whitespace
'the cost of a line is the square of the number of blank spaces at the end
'of a line
Const INFINITY As Long = 1000000
Dim optimalCost As Long
Function Cost(words As Variant, i As Long, j As Long, L As Long) As Long
'words is a 0-based array of strings, assumed to have no white spaces
'i, j are indices in range 0,...,n, where n is UBOUND(words)+1
'L is the maximum length of a line
'Cost returns the cost of a line which begins with words(i) and ends with
'words(j-1). It returns INFINITY if the line is too short to hold the words
'or if j <= i
Dim k As Long
Dim sum As Long
If j <= i Or Len(words(i)) > L Then
Cost = INFINITY
Exit Function
End If
sum = Len(words(i))
k = i + 1
Do While k < j And sum <= L
sum = sum + 1 + Len(words(k)) 'for space
k = k + 1
Loop
If sum > L Then
Cost = INFINITY
Else
Cost = (L - sum) ^ 2
End If
End Function
Function WordWrap(words As Variant, L As Long) As String
'returns string consisting of words with spaces and
'line breaks inserted at the appropriate places
Dim v() As Long, d() As Long
Dim n As Long
Dim i As Long, j As Long
Dim candidate As Long
n = UBound(words) + 1
ReDim v(0 To n)
ReDim d(0 To n)
v(0) = 0
d(0) = -1
For j = 1 To n
v(j) = INFINITY 'until something better is found
i = j - 1
Do
candidate = v(i) + Cost(words, i, j, L)
If candidate < v(j) Then
v(j) = candidate
d(j) = i
End If
i = i - 1
Loop While i >= 0 And candidate < INFINITY
If v(j) = INFINITY Then
MsgBox "Some words are too long for the given length"
Exit Function
End If
Next j
optimalCost = v(n)
'at this stage, optimal path has been found
'just need to follow d() backwards, inserting line breaks
i = d(n) 'beginning of current line
WordWrap = words(n - 1)
j = n - 2
Do While i >= 0
Do While j >= i
WordWrap = words(j) & " " & WordWrap
j = j - 1
Loop
If i > 0 Then WordWrap = vbCrLf & WordWrap
i = d(i)
Loop
End Function
The above function expects an array of words. You would have to split a string before using it as input:
Sub test()
Dim OrigString As String
OrigString = "Alice was beginning to get very tired of sitting by her sister on the bank, and of having nothing to do: once or twice she had peeped into the book her sister was reading, but it had no pictures or conversations in it, and what is the use of a book, thought Alice without pictures or conversations?"
Debug.Print WordWrap(Split(OrigString), 80)
End Sub
Output:
Alice was beginning to get very tired of sitting by her sister on the bank,
and of having nothing to do: once or twice she had peeped into the book
her sister was reading, but it had no pictures or conversations in it, and
what is the use of a book, thought Alice without pictures or conversations?
I have a function in Excel that calculates the Levenshtein Distance between two strings (the number of insertions, deletions, and/or substitutions needed to transform one string into another). I am using this as part of a project I'm working on that involves "fuzzy string matching."
Below you will see the code for the LevenshteinDistance function and a valuePhrase function. The latter exists for the purposes of executing the function in my spreadsheet. I have taken this from what I read in this thread.
'Calculate the Levenshtein Distance between two strings (the number of insertions,
'deletions, and substitutions needed to transform the first string into the second)`
Public Function LevenshteinDistance(ByRef S1 As String, ByVal S2 As String) As Long
Dim L1 As Long, L2 As Long, D() As Long 'Length of input strings and distance matrix
Dim i As Long, j As Long, cost As Long 'loop counters and cost of
'substitution for current letter
Dim cI As Long, cD As Long, cS As Long 'cost of next Insertion, Deletion and
Substitution
L1 = Len(S1): L2 = Len(S2)
ReDim D(0 To L1, 0 To L2)
For i = 0 To L1: D(i, 0) = i: Next i
For j = 0 To L2: D(0, j) = j: Next j
For j = 1 To L2
For i = 1 To L1
cost = Abs(StrComp(Mid$(S1, i, 1), Mid$(S2, j, 1), vbTextCompare))
cI = D(i - 1, j) + 1
cD = D(i, j - 1) + 1
cS = D(i - 1, j - 1) + cost
If cI <= cD Then 'Insertion or Substitution
If cI <= cS Then D(i, j) = cI Else D(i, j) = cS
Else 'Deletion or Substitution
If cD <= cS Then D(i, j) = cD Else D(i, j) = cS
End If
Next i
Next j
LevenshteinDistance = D(L1, L2)
End Function
Public Function valuePhrase#(ByRef S1$, ByRef S2$)
valuePhrase = LevenshteinDistance(S1, S2)
End Function
I am executing this valuePhrase function in a table in one of my sheets where the column and row headers are names of insurance companies. Ideally, the smallest number in any given row (the shortest Levenshtein distance) should correspond to a column header with the name of the insurance company in the table that most closely matches the name of that insurance company in the row header.
My problem is that I am trying to calculate this in a case where the strings in question are names of insurance companies. With that in mind, the code above strictly calculates the Levenshtein distance and is not tailored specifically to this case. To illustrate, a simple example of why this can be an issue is because the Levenshtein distance between two insurance company names can be quite small if they both share the words "insurance" and "company" (which, as you might expect, is common), even if the insurance companies have totally different names with respect to their unique words. So, I may want the function to ignore those words when comparing two strings.
I am new to VBA. Is there a way I can implement this fix in the code? As a secondary question, are there other unique issues that could arise from comparing the names of insurance companies? Thank you for the help!
Your whole question can be replaced by "How do I use the replace function in VBA?". In general, the algorithm in the question looked interesting, thus I have done this for you. Simply add anything in the Array() of the function, it will work (Just write in lower case the values in the array):
Public Function removeSpecificWords(s As String) As String
Dim arr As Variant
Dim cnt As Long
arr = Array("insurance", "company", "firma", "firm", "holding")
removeSpecificWords = s
For cnt = LBound(arr) To UBound(arr)
removeSpecificWords = Replace(LCase(removeSpecificWords), LCase(arr(cnt)), vbNullString)
Next cnt
End Function
Public Sub TestMe()
Debug.Print removeSpecificWords("InsHolding")
Debug.Print removeSpecificWords("InsuranceInsHoldingStar")
End Sub
In your case:
S1 = removeSpecificWords(S1)
S2 = removeSpecificWords(S2)
valuePhrase = LevenshteinDistance(S1, S2)
When I had a similar issue in trying to remove duplicate addresses, I approached the problem the other way and used the Longest Common Substring.
Function DetermineLCS(source As String, target As String) As Double
Dim results() As Long
Dim sourceLen As Long
Dim targetLen As Long
Dim counter1 As Long
Dim counter2 As Long
sourceLen = Len(source)
targetLen = Len(target)
ReDim results(0 To sourceLen, 0 To targetLen)
For counter1 = 1 To sourceLen
For counter2 = 1 To targetLen
If Mid$(source, counter1, 1) = Mid$(target, counter2, 1) Then
results(counter1, counter2) = results(counter1 - 1, counter2 - 1) + 1
Else
results(counter1, counter2) = WorksheetFunction.Max(results(counter1, _
counter2 - 1), results(counter1 - 1, counter2))
End If
Next counter2
Next counter1
'return the percentage of the LCS to the length of the source string
DetermineLCS = results(sourceLen, targetLen) / sourceLen
End Function
For addresses, I've found that about an 80% match gets me close to a hundred percent matches. with insurance agency names (and I used to work in the industry, so I know the problem you face), I might suggest a 90% target or even a mix of the Levenshtein Distance and LCS, minimizing the former while maximizing the latter.
I am trying to replace text markers with certain text that is ordered in a column.
In column Tried..., I am using the below RandCell function to get a random cell from a range of cells:
Function RandCell(Rg As range, columnRange As range, headerRange As range) As Variant
'Dim rplc
Dim textRange
'get random cell
RandCell = Rg.Cells(Int(Rnd * Rg.Cells.Count) + 1)
'find column to replace
' rplc = RandCell.Find(headerRange)
End Function
In the column Wanted, I am using the following formular to substitute the values: =IF(COUNTIF(E3;"*"&$C$2&"*");SUBSTITUTE(E3;$C$2;C3);SUBSTITUTE(E3;$D$2;D3))
However, if I have more than 10 rows this solution is extremely awkward. Hence, I was thinking of implementing a function in vba.
As indicated above I tried to implement the functionality into the RandCell function. However, I am extremely new to vba and kindly ask you for your input!
I appreciate your replies!
UPDATE
Below you can see an example.:
First, a random text is choosen. Then for example in E3 the text marker in the random text is replaced by the value in C or D.
With data like:
in cols A, B, and D, the following macro:
Sub mrquad()
Dim L As Long, M As Long, N As Long, Kount As Long
Dim v1F As String, v1L As String
Kount = 10
With Application.WorksheetFunction
L = .CountA(Range("A:A")) - 1
M = .CountA(Range("C:C")) - 1
N = .CountA(Range("D:D")) - 1
For kk = 1 To Kount
v1 = Cells(.RandBetween(3, L + 2), "A").Value
v1F = Left(v1, Len(v1) - 3)
v1L = Right(v1, 3)
If v1L = "[1]" Then
v2 = Cells(.RandBetween(3, M + 2), "C").Value
Else
v2 = Cells(.RandBetween(3, N + 2), "d").Value
End If
Cells(kk, "F").Value = v1F & v2
Next kk
End With
End Sub
will pick 10 samples at random from column A and, depending on the suffix, pick a random replacement suffix from either column C or column D and place the result in column F:
The number of sample is determined by the Kount variable. The spaces in cols C or D are single spaces rather than empties.
I have 4 variables and wish to list which (maximum of 3) variables are being used.
I have used VBA functions before but I am stumped as to the reason this isn't working..
The four variables are percentages so for example:
if (20%,empty,20%,60%) I want the three cells to be (A,C,D)
if (50%,50%,empty,empty) => (A,B,empty)
Hello,
if (empty,empty,100%,empty) => (C,empty,empty)
The code I have at the moment isn't working (for the first cell):
Function whichtoa(w As Integer, x As Integer, y As Integer, z As Integer) As String
If w <> 0 Then
whichtoa = "A"
ElseIf x <> 0 Then
whichtoa = "B"
ElseIf y <> 0 Then
whichtoa = "C"
ElseIf z <> 0 Then
whichtoa = "D"
End If
End Function
Could it be to do with the empty cells being general and the others being a percentage? I can't really change this as the data is coming from another program.
Could I use a null check or something similar?
Thanks in advance!
Lucas
Consider the following data. the last column has the formula for whichtoA
A B C D E
60% 40% 30% 30% ABC
30% 60% 30% 90% ABC
10% 20% 50% ABC
30% 50% BC
30% C
50% 60% CD
If you are using percentages you need to use something other than integer in your function since you're dealing with decimals.
Function whichtoa(w As Double, x As Double, y As Double, z As Double) As String
Dim emptyCount As Integer
Dim results As String
' Assume zero
valueCount = 0
' Assume empty string
results = ""
If w <> 0 Then
results = results & "A"
valueCount = valueCount + 1
End If
If x <> 0 Then
results = results & "B"
valueCount = valueCount + 1
End If
If y <> 0 Then
results = results & "C"
valueCount = valueCount + 1
End If
' This is the only time you need to check the condition of valueCount. If you want 3 maximum
If (z <> 0) And (valueCount < 3) Then
results = results & "D"
End If
whichtoa = results
End Function
Each condition is checked individually. The If block you have will only process the first match and then stop evaluating the block. Then, counting the number of positive values, or hits if you will, with valueCount we can stop processing if we get 3 hits. This only needs to be checked with z parameter in the event we have 3 hits already at that point. Build the results as a string and return it.
Your conditional statement is chained: each ElseIf is only evaluated if the preceding If evaluates to True, so the function will only return a single string value (either A, B, C, or D but not a combination of multiple possible values, which would require stroing them all in a collection/dictionary/array/etc., and removing the ones that are empty values.
Compounded by implied type conversion (presumably you're passing range objects to this function, on a worksheet, which evaluate to their .Value which is "0" if the range is empty.
Another problem you may not have hit yet (if you're still working through the above) is that if the cell values contain percentages, by casting them as Integer in the function declaration, any values which round down to 0 will be evaluated as zero.
I suggest declaring the variables as Range objects, and then specifically check their .Value property. Store ALL cells and a key value ("A", "B", etc.) in a dictionary. Iterate the dictioanry and check the value for emptiness:
I also use this to return an error value if the dictionary contains 4 items, since you want a maximum of 3.
Function whichtoa(a As Range, b As Range, c As Range, d As Range)
Dim dict As Object
Dim itm As Variant
Set dict = CreateObject("Scripting.Dictionary")
'Add each cell value to a dictionary, using unique letter as Key
dict("A") = a.Value
dict("B") = b.Value
dict("C") = c.Value
dict("D") = d.Value
'iterate the dictionary keys, removing empty values
For Each itm In dict.Keys()
If IsEmpty(dict(itm)) Then dict.Remove (itm)
Next
If Not dict.Count = 4 Then
whichtoa = Join(dict.Keys(), ",")
Else:
whichtoa = CVerr(2023)
End If
End Function
I'm not sure exactly what the return value is that you want (your example are inconsistent), but the following may point you in the right direction:
Public Function whichtoa(r as Range)
Dim arr, i
arr = Array("A", "B", "C", "D")
For i = 0 to 3
If IsEmpty(r.Cells(1,i+1) Then
arr(i) = "empty"
End If
Next
whichtoa = arr(0) & "," & arr(1) & "," & arr(2) & "," & arr(3)
End Function
I am having a sheet which contains range of values like "5670&&2","1281&&-3&-5&&7",... etc. in Column A.
Kindly help me to extract the output in VBA in following way:
For E.g 5670&&2 I require A1 cell contains 5670,B1 cell contains &&,C1 cell contains 2.
For E.g 1281&&-3&-5&&7,I would require that A1 cell contains 1281,B1 cell contains &&-,C1 cell contains 3,D1 cell contains &-,E1 cell contains 5,F1 cell contains && and G1 cell contains 7.
Pls help in the same .
Thanks.,
Here i have tried to write code to separate numbers from non-numbers. Numbers and non-numbers are copied to different columns, like Excel Text-To-Columns. Code is a little crazy, if u need i will provide comments. As input the ActiveSheet.UsedRange.Columns(1).Cells is used.
Option Explicit
Sub SeparateNumbers()
Dim targetRange As Range
Dim cellRange As Range
Dim charIndex As Integer
Dim oneChar As String
Dim nextChar As String
Dim start As Integer
Dim copiedCharsCount As Integer
Dim cellValue As String
Dim columnIndex As Integer
Set targetRange = ActiveSheet.UsedRange.Columns(1).Cells
For Each cellRange In targetRange
columnIndex = cellRange.Column
start = 1
copiedCharsCount = 0
cellValue = cellRange.Value
If (VBA.Strings.Len(cellValue) <= 1) Then GoTo nextCell
For charIndex = 2 To Len(cellValue)
oneChar = VBA.Strings.Mid(cellValue, charIndex - 1, 1)
nextChar = VBA.Strings.Mid(cellValue, charIndex, 1)
If VBA.IsNumeric(oneChar) And VBA.IsNumeric(nextChar) Then GoTo nextCharLabel
If Not VBA.IsNumeric(oneChar) And Not VBA.IsNumeric(nextChar) Then GoTo nextCharLabel
cellRange.Offset(0, columnIndex).Value = VBA.Strings.Mid(cellValue, start, charIndex - start)
columnIndex = columnIndex + 1
copiedCharsCount = copiedCharsCount + (charIndex - start)
start = charIndex
nextCharLabel:
If charIndex = Len(cellValue) Then
cellRange.Offset(0, columnIndex).Value = VBA.Strings.Right(cellValue, charIndex - copiedCharsCount)
End If
Next charIndex
nextCell:
Next cellRange
End Sub
Here is one more code. As a side product, function TextSplitToNumbersAndOther can be used independently as a formula to achieve the same effect.
To prevent accidental firing of the macro in a wrong sheet or a wrong column and overwriting neighbouring columns with scrap, named range "Start_point" should be defined by a user. Below this range in the same column, all data will be processed till the first blank row.
Spreadsheet example: http://www.bumpclub.ee/~jyri_r/Excel/Extracting_symbols_into_columns.xls
Option Explicit
Sub ExtractSymbolsIntoColumns()
Dim rng As Range
Dim row_processed As Integer
Dim string_to_split As String
Dim columns_needed As Long
Dim counter As Long
row_processed = 1
counter = 0
Set rng = Range("Start_point")
While rng.Offset(row_processed, 0).Value <> ""
string_to_split = rng.Offset(row_processed, 0).Value
columns_needed = TextSplitToNumbersAndOther(string_to_split)
For counter = 1 To columns_needed
rng.Offset(row_processed, counter).Value = _
TextSplitToNumbersAndOther(string_to_split, counter)
Next
row_processed = row_processed + 1
Wend
End Sub
Function TextSplitToNumbersAndOther(InputText As String, _
Optional SplitPieceNumber As Long) As Variant
Dim piece_from_split(100) As Variant
Dim char_from_input As String
Dim word_count As Long
Dim counter As Long
Dim char_type(100) As Variant
InputText = Trim(InputText)
If Not IsNull(InputText) Then
word_count = 1
piece_from_split(word_count) = ""
For counter = 1 To Len(InputText)
char_from_input = CharFromTextPosition(InputText, counter)
char_type(counter) = CharTypeAsNumber(char_from_input)
If counter = 1 Then
piece_from_split(word_count) = char_from_input
Else
If (char_type(counter - 1) = char_type(counter)) Then
piece_from_split(word_count) = piece_from_split(word_count) & char_from_input
'Merge for the same type
Else
word_count = word_count + 1
piece_from_split(word_count) = char_from_input
End If
End If
Next
End If
If SplitPieceNumber = 0 Then
TextSplitToNumbersAndOther = word_count
Else
If SplitPieceNumber > word_count Then
TextSplitToNumbersAndOther = ""
Else
TextSplitToNumbersAndOther = piece_from_split(SplitPieceNumber)
End If
End If
End Function
Function CharTypeAsNumber(InputChar As String, Optional PositionInString As Long) As Long
If PositionInString = 0 Then PositionInString = 1
If Not IsNull(InputChar) Then
InputChar = Mid(InputChar, PositionInString, 1)
Select Case InputChar
Case 0 To 9
CharTypeAsNumber = 1
Case "a" To "z"
CharTypeAsNumber = 2
Case "A" To "Z"
CharTypeAsNumber = 3
Case Else
CharTypeAsNumber = 4
End Select
Else
CharTypeAsNumber = 0
End If
End Function
Function CharFromTextPosition(InputString As String, TextPosition As Long) As String
CharFromTextPosition = Mid(InputString, TextPosition, 1)
End Function
You can write a UDF (user defined function) to achieve the objective.
Your two example are in an order (ascending) to filter out into adjacent columns in Excel (A, B, C, D...)
So is it correct to assume logically, that you will never have scenarios where you will have to break the string into non-adjacent columns? e.g. 1234 goes to A, && goes to C, 3 goes to D... resulting in A, C, D.
Asumption 2: That your splitted-string is not going to need columns more than Excel can provide.
Steps you may try:
1. Check your string is not empty
2. Split it by the characters other than numerics
3. At the start and end of each non-numeric character you may proceed to the next adjacent column.
search help: Split a string into multiple columns in Excel - VBA