For example, our cell contains:
EWFS 410461, 501498, EFW406160
So, I need the formula that gets back with
410461 501498 406160
Consider the following User Defined Function:
Public Function GetNumbers(s As String) As String
Dim L As Long, i As Long, wf As WorksheetFunction
Set wf = Application.WorksheetFunction
L = Len(s)
For i = 1 To L
If Mid(s, i, 1) Like "[A-Z]" Or Mid(s, i, 1) = "," Then Mid(s, i, 1) = " "
Next i
GetNumbers = wf.Trim(s)
End Function
All numbers will be returned as a space-separated string
If you have Office 365 you can use this array formula:
=TEXTJOIN(" ",TRUE,IF((ISNUMBER(--MID(A1,ROW($XFD$1:INDEX(XFD:XFD,LEN(A1)-5)),6)))*(NOT(ISNUMBER(--MID(A1&";",ROW($XFD$1:INDEX(XFD:XFD,LEN(A1)-5)),7)))),MID(A1,ROW($XFD$1:INDEX(XFD:XFD,LEN(A1)-5)),6),""))
Being an array formula it must be confirmed with Ctrl-Shift-Enter instead of Enter when exiting Edit Mode.
If "E", "W", "F" and "S" are the only letters you must get rid of, you can avoid VBA and use SUBSTITUTE() function:
=TRIM(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(B2,"E",""),"W",""),"F",""),"S",""),",",""))
a slight variation of Gary's Student's answer:
Public Function GetNumbers2(s As String) As String
Dim i As Long, elem As Variant
For Each elem In Split(s, ",")
For i = 1 To Len(elem)
If Mid(elem, i, 1) Like "[0-9]" Then Exit For
Next i
GetNumbers2 = GetNumbers2 & " " & Application.WorksheetFunction.Trim(Mid(elem, i))
Next
GetNumbers2 = Trim(GetNumbers)
End Function
This answer isn't better than the others with positive scores, but I prefer using ASCII codes for handling characters in a string. This enables ranges that organize cleanly with Select Statements. This is especially useful for rejecting characters from unsophisticated users like my parents (I did not name their grandson "4").
Below is a UDF that would work for the OP, but also shows how one could leverage the VBA Asc function combined with a select statement for handling, upper/lower case, or any other specific characters:
Public Function GiveTheNumbers(theINPUT As String) As String
Dim p As Long, aCode As Long
For p = 1 To Len(theINPUT)
aCode = Asc(Mid(theINPUT, p, 1)) 'converts string to an ascii integer
Select Case aCode
'32 is the ascii code for space bar. 48 to 57 is zero to nine.
Case 32, 48 To 57
GiveTheNumbers = GiveTheNumbers & Chr(aCode) 'Chr() converts integer back to string
'the rest of these cases are not needed for the OP but I'm including for illustration
Case 65 To 90
'all upper case letters
Case 97 To 122
'all lower case letters
Case 33, 64, 35, 36, 37, 42
'my favorite characters of: !##$%*
Case Else
'anything else
End Select
Next p
End Function
NDIGITS (UDF)
Excel Formula
=NDIGITS($A1,6)
Sample Data
VBA Code
'******************************************************************************
' Purpose: From a string, returns digit groups (numbers) in a delimited
' string.
' Inputs
' SourceString - Required. The string to be checked for digits.
' NumberofDigits - Optional. The number of digits in digit groups. If 0,
' all digit groups are returned. Default: 0.
' TargetDelimiter - Optional. The delimiter of the returned string.
' Default: " " (space).
'******************************************************************************
Function NDigits(ByVal SourceString As String, _
Optional ByVal NumberOfDigits As Long = 0, _
Optional ByVal TargetDelimiter As String = " ") As String
Dim i As Long ' SourceString Character Counter
Dim strDel As String ' Current Target String
' Check if SourceString is empty (""). Exit if. NDigits = "".
If SourceString = "" Then Exit Function
' Loop through characters of SourceString.
For i = 1 To Len(SourceString)
' Check if current character is not a digit (#), then replace with " ".
If Not Mid(SourceString, i, 1) Like "#" Then _
Mid(SourceString, i, 1) = " "
Next
' Note: While VBA's Trim function removes spaces before and after a string,
' Excel's Trim function additionally removes redundant spaces, i.e.
' doesn't 'allow' more than one space, between words.
' Remove all spaces from SourceString except single spaces between words.
strDel = Application.WorksheetFunction.Trim(SourceString)
' Check if current TargetString is empty (""). Exit if. NDigits = "".
If strDel = "" Then Exit Function
' Replace (Substitute) " " with TargetDelimiter if it is different than
' " " and is not a number (#).
If TargetDelimiter <> " " And Not TargetDelimiter Like "#" Then
strDel = WorksheetFunction.Substitute(strDel, " ", TargetDelimiter)
End If
' Check if NumberOfDigits is greater than 0.
If NumberOfDigits > 0 Then
Dim vnt As Variant ' Number of Digits Array (NOD Array)
Dim k As Long ' NOD Array Element Counter
' Write (Split) Digit Groups from Current Target String to NOD Array.
vnt = Split(strDel, TargetDelimiter)
' Reset NOD Array Element Counter to -1, because NOD Array is 0-based.
k = -1
' Loop through elements (digit groups) of NOD Array.
For i = 0 To UBound(vnt)
' Check if current element has number of characters (digits)
' equal to NumberOfDigits.
If Len(vnt(i)) = NumberOfDigits Then
' Count NOD Array Element i.e. prepare for write.
k = k + 1
' Write i-th element of NOD Array to k-th element.
' Note: Data (Digit Groups) are possibly being overwritten.
vnt(k) = vnt(i)
End If
Next
' Check if no Digit Group of size of NumberOfDigits was found.
' Exit if. NDigits = "".
If k = -1 Then Exit Function
' Resize NOD Array to NOD Array Element Count, possibly smaller,
' due to fewer found Digit Groups with the size of NumberOfDigits.
ReDim Preserve vnt(k)
' Join elements of NOD Array to Current Target String.
strDel = Join(vnt, TargetDelimiter)
End If
' Write Current Target String to NDigits.
NDigits = strDel
End Function
'******************************************************************************
' Remarks: A digit group are consecutive numbers in the string e.g.
' in the string "123 sdf jk 23 4" there are three digit groups:
' The 1st is 123 with NumberOfDigits = 3, the 2nd is 23 with
' NumberOfDigits = 2 and finally 4 with NumberOfDigits = 1. Since
' they all have a different number of digits, all will be returned
' if NumberOfDigits is 0 or omitted, otherwise only one will be
' returned.
'******************************************************************************
use Right() function and get 6 rightmost character. for example:
Right(cell.Value, 6)
where cell is some Range variable addressing relevant cell
for instance
Dim cell As Range
For Each cell In Range("B2:D2") ' change "B2:D2" to your actual range woth values
Debug.Print Right(cell.Value, 6)
Next
Related
I have a string in a cell composed of several shorter strings of various lengths with blank spaces and commas in between. In some cases only one or more blanks are in between.
I want to remove every blank space and comma and only leave behind 1 comma between each string element. The result must look like this:
The following doesn't work. I'm not getting an error but the strings are truncated at the wrong places. I don't understand why.
Sub String_adaption()
Dim i, j, k, m As Long
Dim STR_A As String
STR_A = "01234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
i = 1
With Worksheets("table")
For m = 1 To Len(.Range("H" & i))
j = 1
Do While Mid(.Range("H" & i), m, 1) = "," And Mid(.Range("H" & i), m - 1, 1) <> Mid(STR_A, j, 1) And m <> Len(.Range("H" & i))
.Range("H" & i) = Mid(.Range("H" & i), 1, m - 2) & Mid(.Range("H" & i), m, Len(.Range("H" & i)))
j = j + 1
Loop
Next m
End With
End Sub
I'd use a regular expression to replace any combination of spaces and comma's. Something along these lines:
Sub Test()
Dim str As String: str = "STRING_22 ,,,,,STRING_1 , , ,,,,,STRING_333 STRING_22 STRING_4444"
Debug.Print RegexReplace(str, "[\s,]+", ",")
End Sub
Function RegexReplace(x_in, pat, repl) As String
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = pat
RegexReplace = .Replace(x_in, repl)
End With
End Function
Just for the sake of alternatives:
Formula in B1:
=TEXTJOIN(",",,TEXTSPLIT(A1,{" ",","}))
The following function will split the input string into pieces (words), using a comma as separator. When the input string has multiple commas, it will result in empty words.
After splitting, the function loops over all words, trims them (remove leading and trailing blanks) and glue them together. Empty words will be skipped.
I have implemented it as Function, you could use it as UDF: If your input string is in B2, write =String_adaption(B2) as Formula into any cell.
Function String_adaption(s As String) As String
' Remove duplicate Commas and Leading and Trailing Blanks from words
Dim words() As String, i As Long
words = Split(s, ",")
For i = 0 To UBound(words)
Dim word As String
word = Trim(words(i))
If word <> "" Then
String_adaption = String_adaption & IIf(String_adaption = "", "", ",") & word
End If
Next i
End Function
P.S.: Almost sure that this could be done with some magic regular expressions, but I'm not an expert in that.
If you have recent Excel version, you can use simple worksheet function to split the string on space and on comma; then put it back together using the comma deliminater and ignoring the blanks (and I just noted #JvdV had previously posted the same formula solution):
=TEXTJOIN(",",TRUE,TEXTSPLIT(A1,{" ",","}))
In VBA, you can use a similar algorithm, using the ArrayList object to collect the non-blank results.
Option Explicit
Function commaOnly(s As String) As String
Dim v, w, x, y
Dim al As Object
Set al = CreateObject("System.Collections.ArrayList")
v = Split(s, " ")
For Each w In v
x = Split(w, ",")
For Each y In x
If y <> "" Then al.Add y
Next y
Next w
commaOnly = Join(al.toarray, ",")
End Function
This preserves the spaces within the smaller strings.
Option Explicit
Sub demo()
Const s = "STRING 22,,,, ,,STRING 1,,,, ,,STRING 333 , , , STRING_22 STRING_44"
Debug.Print Cleanup(s)
End Sub
Function Cleanup(s As String) As String
Const SEP = ","
Dim regex, m, sOut As String, i As Long, ar()
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = True
.MultiLine = False
.IgnoreCase = True
.Pattern = "([^,]+)(?:[ ,]*)"
End With
If regex.Test(s) Then
Set m = regex.Execute(s)
ReDim ar(0 To m.Count - 1)
For i = 0 To UBound(ar)
ar(i) = Trim(m(i).submatches(0))
Next
End If
Cleanup = Join(ar, SEP)
End Function
Code categories approach
For the sake of completeness and to show also other ways "leading to Rome", I want to demonstrate an approach allowing to group the string input into five code categories in order to extract alphanumerics by a tricky match (see [B] Function getCats()):
To meet the requirements in OP use the following steps:
1) remove comma separated tokens if empty or only blanks (optional),
2) group characters into code categories,
3) check catCodes returning alpha nums including even accented or diacritic letters as well as characters like [ -,.+_]
Function AlphaNum(ByVal s As String, _
Optional IgnoreEmpty As Boolean = True, _
Optional info As Boolean = False) As String
'Site: https://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp/74679416#74679416
'Auth.: https://stackoverflow.com/users/6460297/t-m
'Date: 2023-01-12
'1) remove comma separated tokens if empty or only blanks (s passed as byRef argument)
If IgnoreEmpty Then RemoveEmpty s ' << [A] RemoveEmpty
'2) group characters into code categories
Dim catCodes: catCodes = getCats(s, info) ' << [B] getCats()
'3) check catCodes and return alpha nums plus chars like [ -,.+_]
Dim i As Long, ii As Long
For i = 1 To UBound(catCodes)
' get current character
Dim curr As String: curr = Mid$(s, i, 1)
Dim okay As Boolean: okay = False
Select Case catCodes(i)
' AlphaNum: cat.4=digits, cat.5=alpha letters
Case Is >= 4: okay = True
' Category 2: allow only space, comma, minus
Case 2: If InStr(" -,", curr) <> 0 Then okay = True
' Category 3: allow only point, plus, underline
Case 3: If InStr(".+_", curr) <> 0 Then okay = True
End Select
If okay Then ii = ii + 1: catCodes(ii) = curr ' increment counter
Next i
ReDim Preserve catCodes(1 To ii)
AlphaNum = Join(catCodes, vbNullString)
End Function
Note: Instead of If InStr(" -,", curr) <> 0 Then in Case 2 you may code If curr like "[ -,]" Then, too. Similar in Case 3 :-)
[A] Helper procedure RemoveEmpty
Optional clean-up removing comma separated tokens if empty or containing only blanks:
Sub RemoveEmpty(ByRef s As String)
'Purp: remove comma separated tokens if empty or only blanks
Const DEL = "$DEL$" ' temporary deletion marker
Dim i As Long
Dim tmp: tmp = Split(s, ",")
For i = LBound(tmp) To UBound(tmp)
tmp(i) = IIf(Len(Trim(tmp(i))) = 0, DEL, Trim(tmp(i)))
Next i
tmp = Filter(tmp, DEL, False) ' remove marked elements
s = Join(tmp, ",")
End Sub
[B] Helper function getCats()
A tricky way to groups characters into five code categories, thus building the basic logic for any further analyzing:
Function getCats(s, Optional info As Boolean = False)
'Purp.: group characters into five code categories
'Auth.: https://stackoverflow.com/users/6460297/t-m
'Site: https://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp/74679416#74679416
'Note: Cat.: including:
' 1 ~~> apostrophe '
' 2 ~~> space, comma, minus etc
' 3 ~~> point separ., plus etc
' 4 ~~> digits 0..9
' 5 ~~> alpha (even including accented or diacritic letters!)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'a) get array of single characters
Const CATEG As String = "' - . 0 A" 'define group starters (case indep.)
Dim arr: arr = Char2Arr(s) ' << [C] Char2Arr()
Dim chars: chars = Split(CATEG)
'b) return codes per array element
getCats = Application.Match(arr, chars) 'No 3rd zero-argument!!
'c) display in immediate window (optionally)
If info Then Debug.Print Join(arr, "|") & vbNewLine & Join(getCats, "|")
End Function
[C] Helper function Char2Arr
Assigns every string character to an array:
Function Char2Arr(ByVal s As String)
'Purp.: assign single characters to array
s = StrConv(s, vbUnicode)
Char2Arr = Split(s, vbNullChar, Len(s) \ 2)
End Function
I am working on a Function that takes two different cells and looks for
them in a column of strings that is in a different sheet:
Sub search_cellID()
'
'
' Print argument should be written in V7
Range("V7").Select
'flag for the loop
i = 2
if Instr( -16, 'Input'!RiC11,1 ) = -16 Then
Print 'Input'!RiC2
Elseif Instr( -1, 'Input'!RiC11) = -1 Then
Print 'Input'!RiC2
Else: i = i + 1
End If
End Sub
Nevertheless, I am not getting the syntax right. Sorry, I am very new at VBA and trying to figure it out.
You can't do it in this way because there are several errors. For example, you should first work with debug.print.
InStr returns a Variant (Long) specifying the position of the first occurrence of one string within another.
Syntax: InStr([ start ], string1, string2, [ compare ])
The example below uses the InStr function to return the position of the first occurrence of one string within another.
Dim SearchString, SearchChar, MyPos
SearchString ="XXpXXpXXPXXP" ' String to search in.
SearchChar = "P" ' Search for "P".
' A textual comparison starting at position 4. Returns 6.
MyPos = Instr(4, SearchString, SearchChar, 1)
' A binary comparison starting at position 1. Returns 9.
MyPos = Instr(1, SearchString, SearchChar, 0)
' Comparison is binary by default (last argument is omitted).
MyPos = Instr(SearchString, SearchChar) ' Returns 9.
MyPos = Instr(1, SearchString, "W") ' Returns 0.
Copied from: InStr function
For a first start you may want to have a look at:
Private Sub CommandButton1_Click()
Dim cell As Range
For Each cell In Range("b2:b6")
If InStr(cell.Value, "Dr.") > 0 Then
cell.Offset(0, 1).Value = "Doctor"
End If
Next cell
End Sub
I have created a VBA code to remove all special characters available in a column. As an example I have a Alphanumeric character with some special characters in every cells of a column:
Suppose in a cell I have a value: abc#123!-245
After executing my code I got output abc 123 245
Here my code is working fine to remove all the special characters. My code is given below:
Sub ReplaceSpecial()
Dim cel As Range
Dim strVal As String
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Selection
strVal = cel.Value
For i = 1 To Len(strVal)
Select Case Asc(Mid(strVal, i, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122
' Leave ordinary characters alone
Case Else
Mid(strVal, i, 1) = " "
End Select
Next i
cel.Value = strVal
Next cel
Application.ScreenUpdating = True
End Sub
Now if I want to remove the space for my output so that output should look like abc123245, how to do that in VBA?
Input: abc#123!-245
Current Output: abc 123 245
Required Output: abc123245
You could construct a new string with just the permitted characters.
Sub ReplaceSpecial()
Dim cel As Range
Dim strVal As String, temp As String
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Selection
strVal = cel.Value
temp = vbNullString
For i = 1 To Len(strVal)
Select Case Asc(Mid(strVal, i, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122
temp = temp & Mid(strVal, i, 1)
End Select
Next i
cel.Value = temp
Next cel
Application.ScreenUpdating = True
End Sub
My sole intention for this late post was to
test some features of the â–ºApplication.Match() function (comparing a string input against valid characters) and to
demonstrate a nice way to "split" a string into single characters as alternative and possibly instructive solution (see help function String2Arr()).
I don't intend, however to show better or faster code here.
Application.Match() allows not only to execute 1 character searches in an array, but to compare even two arrays in one go,
i.e. a character array (based on an atomized string input) against an array of valid characters (blanks, all digits and chars from A to Z).
As Application.Match is case insensitive, it suffices to take e.g. lower case characters.
All findings of input chars return their position in the valid characters array (otherwise resulting in Error 2042).
Furthermore it was necessary to exclude the wild cards "*" and "?", which would have been considered as findings otherwise.
Function ValidChars(ByVal s, Optional JoinResult As Boolean = True)
'Purp: return only valid characters if space,digits,"A-Z" or "a-z"
'compare all string characters against valid characters
Dim tmp: tmp = foundCharAt(s) ' get array with found positions in chars
'overwrite tmp array
Dim i As Long, ii As Long
For i = 1 To UBound(tmp)
If IsNumeric(tmp(i)) Then ' found in valid positions
If Not Mid(s, i, 1) Like "[?*]" Then ' exclude wild cards
ii = ii + 1
tmp(ii) = Mid(s, i, 1) ' get char from original string
End If
End If
Next
ReDim Preserve tmp(1 To ii) ' reduce to new size
'join tmp elements to resulting string (if argument JoinResult = True)
ValidChars = IIf(JoinResult, Join(tmp, ""), tmp)
End Function
Help function foundCharAt()
Returns an array of found character positions in the valid chars array:
Function foundCharAt(ByVal s As String) As Variant
'Purp: return array of found character positions in chars string
'Note: (non-findings show Error 2042; can be identified by IsError + Not IsNumeric)
Dim chars: chars = String2Arr(" 0123456789abcdefghijklmnopqrstuvwxyz")
foundCharAt = Application.Match(String2Arr(s), chars, 0)
End Function
Help function String2Arr()
Assigns an array of single characters after atomizing a string input:
Function String2Arr(ByVal s As String) As Variant
'Purp: return array of all single characters in a string
'Idea: https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
s = StrConv(s, vbUnicode)
String2Arr = Split(s, vbNullChar, Len(s) \ 2)
End Function
Use a regular expression's object and replace all unwanted characters by using a negated character class. For demonstration purposes:
Sub Test()
Dim str As String: str = "abc#123!-245"
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[^0-9A-Za-z ]"
str = .Replace(str, "")
End With
Debug.Print str
End Sub
The pattern [^0-9A-Za-z ] is a negated character class and captured everything that is not a alphanumeric or a space character. You'll find a more in-depth explaination in this online demo.
At time of writing I'm unsure if you want to leave out the space characters or not. If so, just remove the space from the pattern.
Thought I'd chuck in another alternative using the Like() operator:
For i = Len(str) To 1 Step -1
If Mid(str, i, 1) Like "[!0-9A-Za-z ]" Then
str= Application.Replace(str, i, 1, "")
End If
Next
Or with a 2nd string-type variable (as per #BigBen's answer):
For i = 1 to Len(str)
If Mid(str, i, 1) Like "[0-9A-Za-z ]" Then
temp = temp & Mid(str, i, 1)
End If
Next
If you want to build on your current effort, replace:
cel.Value = strVal
with:
cel.Value = Replace(strVal, " ", "")
Consider:
Sub ReplaceSpecial()
Dim cel As Range
Dim strVal As String
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Selection
strVal = cel.Value
For i = 1 To Len(strVal)
Select Case Asc(Mid(strVal, i, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122
' Leave ordinary characters alone
Case Else
Mid(strVal, i, 1) = " "
End Select
Next i
cel.Value = Replace(strVal, " ", "")
Next cel
Application.ScreenUpdating = True
End Sub
I have an excel sheet with some rows of descriptions in a single column, what I am aiming is to get a vba that would go though all those rows of descriptions and truncate it upto certain character limit for example 30 characters and if the truncation stops at 30 character in the middle of the word then I want the complete word(could extend beyond 30 characters in this case).
I tried to do this with the VBA code below, but I am not able to get what I am looking for.
Function foo(r As Range)
Dim sentence As Variant
Dim w As Integer
Dim ret As String
' assign this cell's value to an array called "sentence"
sentence = Split(r.Value, " ")
' iterate each word in the sentence
For w = LBound(sentence) To UBound(sentence)
' trim to 6 characters:
sentence(w) = Left(sentence(w), 6)
Next
' Join the array back to a string/sentence
ret = Join(sentence, " ")
'Make sure the sentence is max 20 chars:
ret = Left(ret, 20)
'return the value to your function expression:
foo = ret
End Function
I expect the code to go through all the rows of a specific column and truncate it upto 30 characters and if the truncation stops in the middle of the word, then it should keep that word.
Since you tagged it for a formula
=LEFT(A1,FIND(" ",A1,30)-1)
I think you're looking for the instr() function. This could give you the first space-character after position 30.
You would get the following:
Dim SpacePosition as Integer
'return the position for the first space-character after position 29
SpacePosition = Instr(30, r.value," ")
if SpacePosition <> 0 then
'fill ret with the substring up to the first space after position 29
ret = left(r.value, SpacePosition - 1)
else
'if there is no space-character (after position 29) then take the whole string
ret = r.value
end if
Hope that helps.
Best & brilliant solution by #scott Craner. However, In you VBA code you may Change the followings to get required result
'Join the array back to a string/sentence
'ret = Join(sentence, " ")
ret = ""
For w = LBound(sentence) To UBound(sentence)
' trim to 6 characters:
sentence(w) = Left(sentence(w), 6)
ret = ret & IIf(Len(ret) > 0, " ", "") & sentence(w)
If Len(ret) >= 30 Then Exit For
Next w
'Make sure the sentence is max 20 chars:
' ret = Left(ret, 20)
Public Function foo(r As Range, length As Integer) As String
If Len(r.Value) <= length Then
foo = r.Value
Else
foo = Left(r.Value, 1 + length)
foo = RTrim(Left(foo, InStrRev(foo, " ")))
End If
End Function
I suppose you would want to run that by passing 20 as the 2nd parameter
Loop rows from sheet 1, column A starting from row 1:
Option Explicit
Sub test()
Dim Lastrow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
'Insert Code
Next i
End With
End Sub
What I'm trying to do is apply my own function onlyDigits on all the elements in a selection and then sum them.
With array functions, you can do things like
{=SUM(SQRT(A2:A10))}
To sum all of the square roots of a selection. What I want to do is effectively replace SQRT with my own function. Specifically, I want to be able to have something like
{=SUM(PRODUCT(onlyDigits(A2:A10), B2:B10))}
that performs onlyDigits on each element, multiplies it by the one below it, and then adds it to the sum, representing the final sum in one cell.
My function onlyDigits takes its input (a cell) and retrieves only the numbers from it, so it could be a problem with not only receiving numerical input (but I'm not sure, hence I'm here). Here's the source, I copied it from a different question:
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
Is this possible? If so, how can I do it? Much thanks!
You need to return an array:
Function onlyDigits(s As Range) As Variant()
' Variables needed (remember to use "option explicit"). '
Dim retval() As Variant ' This is the return string. '
Dim i As Integer ' Counter for character position. '
' Initialise return string to empty '
ReDim retval(1 To s.Cells.Count)
' For every character in input string, copy digits to '
' return string.
For j = 1 To s.Cells.Count '
For i = 1 To Len(s(j))
If IsNumeric(Mid(s(j), i, 1)) Then
retval(j) = retval(j) + Mid(s(j), i, 1)
End If
Next i
retval(j) = CLng(retval(j))
Next j
' Then return the return string. '
onlyDigits = retval
End Function
The array returned is horizontal, so you need to transpose it:
=SUMPRODUCT(TRANSPOSE(onlyDigits(A1:A5)),B1:B5)
It needs to be array entered with Ctrl-Shift-Enter.