I am having trouble stripping any numbers from a string. In Excel, I have many string fields that may contain numbers. I only care about the number(s), the rest of the characters are unwanted and will be discarded. The number may be in any position, not a set location.
For example:
'2 CATCH BASINS' or 'CATCH BASINS x2'
I based my code on this SO answer, but I can't seem to get it to work. The error message is 'Application-defined or object-defined error'.
Option Explicit
Function onlyDigits(s As String) As String
' Variables needed (remember to use "option explicit"). '
Dim retval As String ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
retval = ""
' For every character in input string, copy digits to '
' return string. '
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
' Then return the return string. '
onlyDigits = retval
End Function
Public Sub CommandButton1_Click()
Application.ScreenUpdating = False
' -----------------------------------------------------------------------------------------
' Will strip numbers from descriptions for basins, guy wires, water meters/valves & pull box
' -----------------------------------------------------------------------------------------
Dim counter As Integer 'Index for the While Loop
Dim fCode As String 'Variable for column E, feature code
Dim fDesc As String 'Variable for column F, the descriptor
Do While Cells(counter, 1).Value <> "" 'While the first column has any data, keep looping
fCode = Cells(counter, 5).Value 'Populate feature code variable from column E
If (fCode = "XCB") Or (fCode = "XGW") Or (fCode = "XWV") Or (fCode = "XWM") Then
fDesc = Cells(counter, 6).Value
Cells(counter, 6).Value = onlyDigits(fDesc)
Else
'do nothing
End If
counter = counter + 1
Loop 'Finishes checking for numbers within specific descriptors
Can someone point me in the right direction? It would be much appreciated!!
Do While Cells(counter, 1).Value
Here counter is zero but range indexes start at 1 hence the error.
Related
I would like to print each substrings in between the "..." from this string: "...covid...is...very...scary" in consecutive cells in a column in excel.
this is my code in VBA.
Sub copyd()
findandcopy("...covid...is...very...scary") 'not sure how to print in consecutive cells of a column
End Sub
Function findandcopy(brokenstr As String) As String
Dim first, second As Integer
Dim strtarget as string
strtarget = "..."
Do until second =0. 'second=0 so that loop ends when there is no more "..." found
first = InStr(brokenstr, strtarget)
second = InStr(first + 3, brokenstr, strtarget)
findandcopy = Mid(purpose, first +3, second - first -3) 'referred to https://stackoverflow.com/questions/2543225/how-to-get-a-particular-part-of-a-string#_=_
first = second 'so that loop can find next "..."
Loop
End Function
can anyone please advise? thank you for your help :)
Try this code:
Option Explicit
Sub copyd()
Dim arr As Variant
' get splitted text into horizontal array arr()
arr = Split("...covid...is...very...scary", "...")
If UBound(arr) > 0 Then ' if there is something in the array, display it on the sheet
' put onto sheet values from transposed array arr()
ThisWorkbook.Worksheets(1).Range("A1"). _
Resize(UBound(arr) + 1, 1).Value = _
WorksheetFunction.Transpose(arr)
End If
End Sub
Ahh, why not just split the string by "..."?
Like:
Function findandcopy(brokenstr As String, targetStr as string)
dim substr()
if instr(1, brokenstr, targetStr, vbTextCompare) > 0 then
'brokenstr has at least one instance of targetStr in it
brokenstr2 = split(brokenstr,targetStr)
if brokenstr2(0) = "" then
redim substr(ubound(brokenstr2)-1)
iStart = 1
else
redim substr(ubound(brokenstr2))
iStart = 0
end if
for i = iStart to ubound(brokenstr2)
substr(i-iStart) = brokenstr2(i)
next i
else
'No instances of targetStr in brokenstr
redim substr(0)
substr(0) = brokenstr
end if
findandcopy = substr
end function
Which will return an array of strings which are the bits between targetStr. Then you can do with it as you please within the parent sub.
If you start doing comparisons with the results and find issues - you can remove whitespace by modifying above as:
substr(i) = trim(brokenstr2(i))
and your calling code:
Sub main()
Dim covid as string
Dim remove as string
covid = "...covid...is....very...scary"
'covid = "really...covid...is...very...scary" 'For testing
remove = "..."
rtn = findandcopy(covid, remove)
end sub
I am trying to print out "OK" value if the statements same value with "NumberPallete" but my code doesn't work right.
I have two conditions to compare from one cell value ["54# / 221"]. The first condition value for "SeriesNumber" is [88] and then the Second condition value for "NumberPallete" is [221#]. I am using looping for "SeriesNumber" and "NumberPallete" to find the value because I have long data in the table sheet.
and then from the different sheets using looping too, I am starting with the First condition checks "SeriesNumber" value if the value is right, then check the second condition from "NumberPallete" value, in this condition, I want a print out "ok" value but "ok" value doesn't print out.
I am sorry, my English is poor. I'm trying my best to explain. Please help me.
Dim NumberPallete As String
Dim SeriesNumber As String
Dim I As Long
Dim j As Long
Dim z As Long
i = Cells(Rows.Count, 15).End(xlUp).Row
For j = 6 To i
'Cells(j, 20).Value = Right(Cells(j, 15).Value, Len(Cells(j, 15)) - InStr(1, Cells(j, 15).Value, "/"))
SeriesNumber = Right(Cells(j, 15).Value, Len(Cells(j, 15)) - InStr(1, Cells(j, 15).Value, "/"))
'Cells(j, 21).Value = Left(Cells(j, 15).Value, Len(Cells(j, 15)) - InStr(1, Cells(j, 15).Value, "/"))
NumberPallete = Left(Cells(j, 15).Value, Len(Cells(j, 15)) - InStr(1, Cells(j, 15).Value, "/"))
If SeriesNumber = 221 Then
For z = 4 To 250
If Worksheets("AAA").Cells(z, 2).Value = NumberPallete Then
Worksheets("AAA").Cells(z, 6).Value = "OK"
End If
Next z
Else
MsgBox ("Not OK")
End If
Next j
I may not have fully understood what you are trying to do but the code below is doing something and, hopefully, it can be fixed to do what you want.
Sub FindPalletNumber()
' 062
' you can find code to enter 2 values with input boxes at this link:-
' https://stackoverflow.com/questions/62651211/vba-excel-search-in-excel-specific-word-and-delete-all-rows-who-does-not-have-t
Dim Snum As Integer ' serial number
Dim Pnum As Integer ' pallet number
Dim Txt As String ' message text
Snum = 221 ' number only
Pnum = 54 ' no # sign, no brackets
If MarkOK(Snum, Pnum) Then
Txt = "Found and marked."
Else
Txt = "No match found."
End If
MsgBox Txt, vbInformation, "Action report"
End Sub
Private Function MarkOK(Snum As Integer, _
Pnum As Integer) As Boolean
' 062
' return True if found and marked
Const Pallet As Long = 0 ' element of array Nums
Const Serial As Long = 1 ' element of array Nums
Dim Nums() As String ' split cell pattern "54# / 221"
Dim Done As Boolean ' True if found
Dim R As Long ' loop counter: Row in ActiveSheet
Dim R2 As Long ' loop counter: Row in Ws("AAA")
For R = 6 To Cells(Rows.Count, 15).End(xlUp).Row
Nums = Split(Cells(R, 15).Value, "/")
' Nums(Pallet) = "54# ", Nums(Serial) = " 221"
If Val(Nums(Serial)) = Snum Then
With Worksheets("AAA")
For R2 = 4 To .Cells(.Rows.Count, 2).End(xlUp).Row
If .Cells(R2, 2).Value = Trim(Nums(Pallet)) Then
.Cells(R2, 6).Value = "OK"
Done = True
Exit For
End If
Next R2
End With
End If
If Done Then Exit For ' stop search if found
Next R
MarkOK = Done
End Function
In the first procedure the Pallet and Serial numbers should be set (Pnum and Snum). Then, when you run that procedure, it will call the other one which reports back whether a match was found or not. I have added a link where you can find code to get the two values from Input boxes, if that is what you need.
The function looks for the serial number in the ActiveSheet. If found, it looks for the pallet number in Sheet("AAA"). This is confusing because it looks for the pallet number found in the ActiveSheet, not the pallet number specified in the search. The pallet number in the search specs ends up not being used at all. Perhaps it's not needed.
Anyway, when the pallet is found the row is marked and the search terminates. If the pallet number isn't found the loop in the ActiveSheet is continued to look for another instance of the serial number. Note that the code is not enabled to find multiple pallets with the same serial number.
I have a macro that goes through a list of text, extracts the dollar amounts, increase them by 12%, and replaces the text with the updated dollar amounts.
This what a couple rows of data looks like:
This is the result after I run the macro:
I would need the 72.8 to be 72.80 tho, for example.
Sometimes the result would just have 1 decimal place and sometimes it would have 3. The Round function works fine for me with truncating the result down to 2 decimal places, but doesn't help adding a 0 to keep the number at two decimal places.
I need a way to have fill the second decimal place with a 0 if the result only has 1 decimal place.
This is the macro:
Function onlyDigits(s As String) As String
' Variables needed (remember to use "option explicit"). '
Dim retval As String ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
retval = ""
' For every character in input string, copy digits to '
' return string. '
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
' Then return the return string. '
onlyDigits = retval
End Function
Sub ChangeDollarAmount()
Dim qtyspec As String
Dim previousDollarIndex As Integer
Dim dollarSignCount As Integer
Dim dollarString As String
Dim originalDollarAmount As String
Dim changedDollarAmount As Double
Dim isANumber As Boolean
previousDollarIndex = 1
' row count
lastrow = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
For Each cell In Range("K2:K" & lastrow)
Debug.Print cell.Formula
previousDollarIndex = 1
qtyspec = cell.Formula
dollarSignCount = (Len(cell.Formula) - Len(Replace(cell.Formula, "$", ""))) / Len("$")
' loop through dollar amounts in text
For i = 1 To dollarSignCount
isANumber = False
previousDollarIndex = InStr(previousDollarIndex + 1, cell.Formula, "$")
originalDollarAmount = Mid(cell.Formula, previousDollarIndex, 8)
Do While isANumber = False
If Not IsNumeric(Right(originalDollarAmount, 1)) Then
originalDollarAmount = Left(originalDollarAmount, Len(originalDollarAmount) - 1)
Else
isANumber = True
End If
Loop
' extract only digits from dollar amount ($345.23 -> 34523)
dollarAmount = onlyDigits(originalDollarAmount)
' add decimal point and increase dollar amount by 12% (34523 -> 345.23 -> 386.66)
changedDollarAmount = Round(CDbl(dollarAmount) * 1.12 * 0.01, 2)
' update the dollar amount in the text
cell.Formula = Replace(cell.Formula, originalDollarAmount, "$" + CStr(changedDollarAmount))
Next i
Next cell
End Sub
changedDollarAmount = CDbl(dollarAmount) * 1.12 * 0.01
cell.Formula = Replace(cell.Formula, originalDollarAmount, Format$(changedDollarAmount, "$0.00"))
Another difficult task for me...
I have a excel sheet like this...
In the first column there are two Aas, their values are shown in the second column, which is A string and Astring.
A string and Astring differ only from one blank key. I want to use excel VBA to say, these two values are equal, as long as they are same in the first column, but differ only from one letter in the second column. One of them should be deleted then. [shown in the "target" part]
Similarly, there are two Dds, their values differ only from a ;.
Here I wrote some code, but I dont know how to do the if algorithmus.
Sub deletesimilars()
Dim lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
For i = lr To 1 Step -1 'reverse loop
If Cells(i, 1) = Cells(i - 1, 1) Then
' if cells(i,2) ??? cells(i-1,2) then ' I stuck here
Cells(i, 1) = ""
Cells(i, 2) = ""
End If
End If
Next i
End Sub
Thanks!!!
I've run into this previous in my work, when I want to guarantee the "equivalence" of certain string. So my technique is to "normalize" the strings by focusing on the important content of the string.
In most of my cases, this means:
stripping all whitespace (usually not important anyway)
converting everything to lowercase (case is often not important to me)
sometimes ignoring certain special characters
So I have a utility function called NormalizeString that performs these actions.
Your code then becomes:
Option Explicit
Sub DeleteSimilars()
Dim thisSH As Worksheet
Dim lastRow As Long
Set thisSH = ActiveSheet
lastRow = thisSH.UsedRange.Rows.Count
Dim i As Long
For i = lastRow To 2 Step -1
If thisSH.Cells(i, 1) = thisSH.Cells(i - 1, 1) Then
If NormalizeString(thisSH.Cells(i, 2), ";") = _
NormalizeString(thisSH.Cells(i - 1, 2), ";") Then
thisSH.Cells(i, 1) = vbNullString
thisSH.Cells(i, 2) = vbNullString
End If
End If
Next i
End Sub
Function NormalizeString(ByVal inputStr As String, _
Optional ByVal specialChars As String) As String
'--- "normalizes" a string by a series of modifications, such as
' -- removes all whitespace
' -- converts all characters to lowercase
' -- removes other "special" characters that should not
' be considered part of the string
Dim returnString As String
returnString = Replace(inputStr, " ", "", , , vbTextCompare)
returnString = LCase(returnString)
If Not IsMissing(specialChars) Then
Dim i As Integer
For i = 1 To Len(specialChars)
returnString = Replace(returnString, _
Mid(specialChars, i, 1), "", , , vbTextCompare)
Next i
End If
NormalizeString = returnString
End Function
theStr = "KT150"
Characters count is always 5 in total. I want to make sure that there is 3 numbers in theStr. How would I achieve this in Excel VBA?
You do not need VBA to get the number of digits in a string, but here is one way to count them:
Public Function KountNumbers(r As Range) As Long
Dim i As Long, t As String
t = r.Text
For i = 1 To Len(t)
If Mid(t, i, 1) Like "[0-9]" Then KountNumbers = KountNumbers + 1
Next i
End Function
for example:
Without VBA try this:
=SUMPRODUCT(LEN(A1)-LEN(SUBSTITUTE(A1,{0,1,2,3,4,5,6,7,8,9},"")))
to get the number of numeric digits.
Your question is a little lacking in detail, but how about:
Sub test()
Debug.Print containsXnumbers("KT150", 3)
End Sub
Function containsXnumbers(sInput As String, xNumbers As Long) As Boolean
Dim x As Long
Dim numCount As Long
For x = 1 To Len(sInput)
If IsNumeric(Mid(sInput, x, 1)) Then numCount = numCount + 1
Next x
If numCount = xNumbers Then containsXnumbers = True
End Function
This should help:
Function onlyDigits(s As String) As String
' Variables needed (remember to use "option explicit"). '
Dim retval As String ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
retval = ""
' For every character in input string, copy digits to '
' return string. '
For i = 1 To Len(s)
If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
retval = retval + Mid(s, i, 1)
End If
Next
' Then return the return string. '
onlyDigits = retval
End Function
Example:
Dim myStr as String
myStr = onlyDigits ("3d1fgd4g1dg5d9gdg")
MsgBox (myStr)
Will return (in a message box):
314159
*Code is exact copy of this SO answer
try with the below formula
Assume that your data are in A1. Apply the below formula in B1
=IF(AND(LEN(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A1,"1",""),"2",""),"3",""),"4",""),"5",""),"6",""),"7",""),"8",""),"9",""),"0",""))=2,LEN(A1)=5),"3 character numerals","No 3 numerals found")