I need help coming up with a function that detects a certain number of consequential numbers in a cell or range of cells.
I have a bunch of data in the form of descriptions with a sequence of an 8 digit number hidden between text. I need to be able to detect this 8 digit number in a cell and extract it to another cell.
The reason I can't just extract all the numbers in a string is because there are also other numbers in the same cell, so I need to be able to detect an 8 digit number specifically.
Thanks in advance!
This will give you the first 8-digits that is contained in any String.
Sub Selvi()
MsgBox GetConsequentialDigits(Cells(1, 1), 8)
End Sub
I made this into a function so that you can also use it directly into Excel like this :
=GetConsequentialDigits(A1,8)
And here is the function :
Public Function GetConsequentialDigits(ByVal InCellString As String, ByVal DigitsNumber As Integer) As String
Dim Cpt As Integer, _
TpStr As String, _
TpRez As String
Cpt = 0
TpRez = vbNullString
For i = 1 To Len(InCellString) - 1
If Cpt < DigitsNumber Then
TpStr = Mid(InCellString, i, 1)
If IsNumeric(TpStr) Then
Cpt = Cpt + 1
Else
Cpt = 0
End If
Else
TpRez = Trim(Mid(InCellString, i - DigitsNumber, DigitsNumber))
Exit For
End If
Next i
GetConsequentialDigits = TpRez
End Function
Related
I would like to convert a range of numbers (and single digits) from a number-only format to alpha-numeric format. Entire statement is in a single, excel cell and would like the converted version to be in a neighboring cell.
As an example:
Assuming 1-24=B1-B24
Assuming 25-48=C1-C24
INPUT—
screen 1-3,5,7-9,11-30,32-37,39-40,41,44-46
DESIRED OUTPUT (all acceptable)
screen B1-B3,B5,B7-B9,B11-C6,C8-C13,C15-C16,C17,C20-C22
OR
screen B1-B3,B5,B7-B9,B11-B24,C1-C6,C8-C13,C15-C16,C17,C20-C22
OR
screen B1-B3,B5,B7-B9,B11-B24
screen C1-C6,C8-C13,C15-C16,C17,C20-C22
Using excel functions is proving quite cumbersome so excel macro would be better. I've looked for examples of requested conversion but haven't found anything.
Any help is greatly appreciated.
Cheers,
Bob
Hey here is a solution that i tested out. Not sure if "screen" needs to be in the string or not. Let me know and I will tweak it if that's the case.
Its a user defined function. So drop this vba in a module and then go to a worksheet and type in "=AlphaConvert(" + the cell reference.
Assumption here is that only one cell will be referenced at a time.
Last this could easily be converted to a sub routine and probably run a bit faster than the function.
Public Function AlphaConvert(TargetCell As Range)
Dim v As Long
Dim vArr() As String
Dim i As Long
Dim iArr() As String
Dim a As String
vArr = Split(TargetCell.Value, ",")
For v = LBound(vArr) To UBound(vArr)
If InStr(vArr(v), "-") > 0 Then
iArr = Split(vArr(v), "-")
For i = LBound(iArr) To UBound(iArr)
If i = LBound(iArr) Then
a = AlphaCode(iArr(i))
Else
a = a & "-" & AlphaCode(iArr(i))
End If
Next i
vArr(v) = a
Else
vArr(v) = AlphaCode(vArr(v))
End If
If v = LBound(vArr) Then
AlphaConvert = vArr(v)
Else
AlphaConvert = AlphaConvert & "," & vArr(v)
End If
Next v
End Function
Private Function AlphaCode(Nbr As Variant)
Select Case Nbr
Case 1 To 24
AlphaCode = "B" & Nbr
Case Else
AlphaCode = "C" & Nbr - 24
End Select
End Function
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.
I am writing a VBA code that goes through a defined matrix size and filling cells randomly within its limits.
I got the code here from a user on stackoverflow, but after testing it I realized that it does not fit for avoiding duplicate filling, and for instance when filling 5 cells, I could only see 4 cells filled, meaning that the random filling worked on a previously filled cell.
This is the code I'm working with:
Dim lRandom As Long
Dim sCells As String
Dim sRandom As String
Dim rMolecules As Range
Dim i As Integer, j As Integer
Dim lArea As Long
lArea = 400 '20x20
'Populate string of cells that make up the container so they can be chosen at random
For i = 1 To 20
For j = 1 To 20
sCells = sCells & "|" & Cells(i, j).Address
Next j
Next i
sCells = sCells & "|"
'Color the molecules at random
For i = 1 To WorksheetFunction.Min(5, lArea)
Randomize
lRandom = Int(Rnd() * 400) + 1
sRandom = Split(sCells, "|")(lRandom)
Select Case (i = 1)
Case True: Set rMolecules = Range(sRandom)
Case Else: Set rMolecules = Union(rMolecules, Range(Split(sCells, "|")(lRandom)))
End Select
sCells = Replace(sCells, "|" & sRandom & "|", "|")
lArea = lArea - 1
Next i
rMolecules.Interior.ColorIndex = 5
Using this same exact code which works perfectly, WHAT can I insert and WHERE do I do that so that the code would check if a cell is previously already filled with a string or a color?
I feel as though this code I'm looking for should be right before
rMolecules.Interior.ColorIndex = 5
But I'm not sure what to type.
EDIT
From the comments I realized that I should be more specific.
I am trying to randomly fill cells with the blue color (.ColorIndex = 5), but what I need to check first is if the randomizing hadn't marked a cell twice, so that for instance in this case, if I want to mark 5 different cells, it marks only 4 of them because of a duplicate and thus fills only 4 cells with the blue color. I need to avoid that and make it choose another cell to mark/fill.
I'd appreciate your help.
Keep the cells you use in a Collection and remove them as you fill the random cells:
Sub FillRandomCells(targetRange As Range, numberOfCells As Long)
' populate collection of unique cells
Dim c As Range
Dim targetCells As New Collection
' make sure arguments make sense
If numberOfCells > targetRange.Cells.Count Then
Err.Raise vbObjectError, "FillRandomCells()", _
"Number of cells to be changed can not exceed number of cells in range"
End If
For Each c In targetRange.Cells
targetCells.Add c
Next
' now pick random 5
Dim i As Long, randomIndex As Long
Dim upperbound As Long
Dim lowerbound As Long
For i = 1 To numberOfCells
lowerbound = 1 ' collections start with 1
upperbound = targetCells.Count ' changes as we are removing cells we used
randomIndex = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Set c = targetCells(randomIndex)
targetCells.Remove randomIndex ' remove so we don't use it again!
c.Interior.Color = 5 ' do what you need to do here
Next
End Sub
Sub testFillRandomCells()
FillRandomCells ActiveSheet.[a1:t20], 5
FillRandomCells ActiveSheet.[b25:f30], 3
End Sub
EDIT: Changed to make the target range and number of changed cells configurable as arguments to a function. Also added error checking (always do that!).
Why not build a list of random numbers and place in a Scripting.Dictionary, one can use the Dictionary's Exist method to detect duplicates, loop through until you have enough then you can enter your colouring code confident that you have a unique list.
I have a column of addresses and I have to find those which don't contain street numbers. Unfortunately, addresses have been input by various users and they do not follow the same pattern so the street type, street name, suburb are in different order and I can't use functions like LEFT, RIGHT or MID to check if particular character is a number. The column looks like this:
10 Willsons Drive, Manhattan
Epping, 23 Wet Rd
Longsdale St, Kingsbury
11 Link Crt, Pakenham
Is there an Excel or VBA function that can tell me if cell / string contains numbers?
Put this into a Module, then in your worksheet, may be a column next to it, put formula =HaveNumbers(A2) and check if you want it like that (True/False). You can change it to Return a String instead. This Returns TRUE / FALSE.
Function HaveNumbers(oRng As Range) As Boolean
Dim bHaveNumbers As Boolean, i As Long
bHaveNumbers = False
For i = 1 To Len(oRng.Text)
If IsNumeric(Mid(oRng.Text, i, 1)) Then
bHaveNumbers = True
Exit For
End If
Next
HaveNumbers = bHaveNumbers
End Function
There isn't a single VBA function that will do what you want, but the following function should do the trick:
Public Function ContainsNumbers(Inp As String) As Boolean
Dim Strings() As String, Str As Variant
Strings = Split(Inp, " ")
For Each Str In Strings
If IsNumeric(Str) Then
ContainsNumbers = True
Exit For
End If
Next
End Function
Then put something like =ContainsNumbers(A1) in a nearby cell.
Thanks Monty. In my case, though, numbers were not always separated from words so I had to iterate over each character. I used following:
Function ContainsNumber(text As String)
'checks if given cell contains number
For i = 1 To Len(text)
If IsNumeric(Mid$(text, i, 1)) Then
ContainsNumber = True
Exit Function
End If
Next
ContainsNumber = False
End Function
This requires a solution & the code to migrate to Access from VB6 is below.
I have a function to compare characters that comes from VB6 and I am a novice user on VB6 and mostly work from VBA platform. I need to setup a class or a better way in MS Access to check character by character for typo mistakes without the use of UDT.
Mytypolist as an array refers to the following dataset:
QWA WESAQ ERDSW RTFDE TYGFR YUHGT UIJHY IOKJU OPLKI PLO AQWSZ SEDXZA DRFCXSE FTGVCDR GYHBVFT HUJNBGY JIKMNHU KOLMJI LPKO ZASX XZSDC CXDFV VCFGB BVGHN NBHJM MNJK
The above data is used to compare if a character was mistyped in a word.. ex. if I use A as in Auebec instead of what I mean to type Quebec, my cluster of interest is QWA; WESAQ; AQWSZ; or any other Q arrangement on a standard English Qwerty keyboard based on proximity. And this is not just for Q, but for entire set of alphabets, regardless of case, so c has its own cluster of possible typo matches etc..
In VB6 setup of UDT (user defined type):
'declare UDT type for typos
Public Type Mytypos
Rightrkey As String * 1
PossibleKey As String * 8
End Type
'declare arrays and variable for master list and typos
Public Masterlist() As String
Public Mytypolist(26) As Mytypos
Public Matchkey As Mytypos
the following function compares two words; and assign similarity by calculating currentpct score:
Public Function CompareCharacters(ByRef MasterWord As String, _
ByRef Checkword As String, ByRef CurrentPCT As Double, _
ByRef WordVal As Long) As Double
'define function variables
Dim ChrCount As Long
Dim ChrValue As Long
Dim loop1 As Long
Dim loop2 As Long
'define the letter values
If Len(MasterWord) > Len(Checkword) Then
ChrCount = Len(MasterWord) * 2
Else
ChrCount = Len(Checkword) * 2
End If
ChrValue = 1 / ChrCount
'say CURRENT PCT has a value of 10%
'check each letter for a match in current word position
For loop1 = 1 To Len(Checkword)
'check for typo errors (key proximity)
For loop2 = 0 To UBound(Mytypolist)
Matchkey = Mytypolist(loop2)
'if indexkey = letter in masterword
If Matchkey.Rightrkey = Mid(MasterWord, loop1, 1) Then
'does the letter in the checkword exist in the proximity keylist
If InStr(1, Matchkey.PossibleKey, Mid(Checkword, loop1, 1), vbTextCompare) > 0 Then
'value for letter found in proximity keylist
CurrentPCT = CurrentPCT + ChrValue
End If
Exit For
End If
Next loop2
Next loop1
CompareCharacters = CurrentPCT
End Function
IF you can post me a array/class solution that may not produce compiler issues (String UDT in VBA are a problem). Please check it out now!
It would probably best, since you have a 1 character to 8 character thing, to just have a full mapping. Something to replace this:
Public Type Mytypos
Rightrkey As String * 1
PossibleKey As String * 8
End Type
To:
PossibleKeys(255) As String * 8
That way, each character (from 0 to 255) would have the 8 character mapping. No UDT required!