I'm trying to format some number data. For each cell within the range I need to replace the first number only with the corresponding letter. 1 = A, 2 = B etc. and then delete the 2nd and 3rd numbers.
So for example:
11111 --> A11
12345 --> A45
23456 --> B56
56789 --> E89
Is there a simple way to do that with formatting? I only need to go up to E.
Here's a little VBA code to accomplish what you need:
s = "56789"
s = Chr(Asc(Mid(s, 1, 1)) + 16) & Mid(s, 4)
My suggestion would be
Option Explicit
Function conA_E(inp As String) As String
Dim res As String
Dim ch As String
On Error GoTo EH
ch = Left(inp, 1)
If ch <= 6 And ch >= 1 Then
res = Chr(Asc(Mid(inp, 1, 1)) + 16) & Mid(inp, 4)
Else
'res = ch & Mid(inp, 4) ' In Case 2nd and 3rd digit should always be deleted
res = inp ' No change if first digit is bigger than 5
End If
conA_E = res
Exit Function
EH:
conA_E = inp
End Function
Sub TestIt()
Dim inp As String
inp = "1214222"
Debug.Print conA_E(inp)
End Sub
Related
Through my work, and copying others, I have cobbled together a Excel VBA Sub that separates a long sting with groups of (text groups) and (number groups) into a replacement string with spaces in between each seperate group; as per this example:
• “123abc12aedsw2345der”
• …Apply selection Sub() then becomes:
• “123 abc 12 aedsw 2345 der”
It converts the string in its original cell as per the “selection”, so I am currently left with the altered data in is original cell
PROBLEM: I would like to change this into a FUNCTION where the transformed data would appear in the Function cell and leave the original cell intact. I have done hundreds of these but I cannot seem to get this to work as an independent FUNCTION. Below the finished and working Sub Routine I am trying to convert to an independent function to call from anywhere on the worksheet:
Sub SplitTextNumbersSelection()
Dim c As Range
'********** Inserts Space Before Number Groups ******************************
For n = 1 To 10
For Each c In Selection
c = InsertSpace(c.Text)
Next
Next n
'****************Inserts Space Before Letter Groups ***********************
For n = 1 To 10
For Each c In Selection
c = InsertSpace2(c.Text)
Next
Next n
'****************************************
End Sub
Function InsertSpace(str As String) As String
With CreateObject("vbscript.regexp")
.Pattern = "([a-z])(\d)"
'.Pattern = "(\d)([a-z])"
InsertSpace = .Replace(str, "$1 $2")
End With
End Function
Function InsertSpace2(str As String) As String
With CreateObject("vbscript.regexp")
'.Pattern = "([a-z])(\d)"
.Pattern = "(\d)([a-z])"
InsertSpace2 = .Replace(str, "$1 $2")
End With
End Function
Bit simpler:
Function PrepString(v As String)
Dim rv As String, i As Long, c1, c2
For i = 1 To Len(v) - 1
c1 = Mid(v, i, 1)
c2 = Mid(v, i + 1, 1)
If (c1 Like "[a-z]" And c2 Like "[0-9]") Or _
(c2 Like "[a-z]" And c1 Like "[0-9]") Then
rv = rv & c1 & " "
Else
rv = rv & c1
End If
Next i
PrepString = rv & Right(v, 1)
End Function
I'm trying to turn general data written as fractions like 3/4" or 13 7/32" into 3 place decimal numbers such as 0.750 or 13.219.
I have a working table replacement that handles 0 to 1" fractions. It can't handle the mixed numbers like 13 7/32". It leaves me with 13 0.219 which is why I need to replace " 0." with "." to join the 13 and 219 together with a decimal.
We do this data conversion in multiple steps and hand type because Excel tries converting some fractions like 3/4" into a date.
Original data
Resulting data
Sub FractionConvertMTO()
'this section works
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
Selection.Replace what:=Cells(i, 21).Value, Replacement:=Cells(i, 22).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next
'this section doesn't work
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
str1 = " "
str1 = Trim(Replace(str1, " ", "+"))
Next
'this section changes the format.
For i = 66 To 130
Range("F6:H48").NumberFormat = "0.000"
Next
'this section is supposed to add an = sign in front of the cell contents but doesn't work.
Dim Cell As Range
For Each Cell In Range("F6:H48")
Cell.Value = "=" & Cell.Value
Next Cell
'this section works to highlight the first cell
Worksheets("BOM").Cells(1, 1).Select
End Sub
I dug up the following method from my library of useful functions. It converts numbers represented as a fractional string to the numeric equivalent. Simply loop through the cells needing conversion and call this method:
Public Function FractionToNumber(ByVal Value As String, Optional ByVal Digits As Long = 0) As Double
Dim P As Integer
Dim N As Double
Dim Num As Double
Dim Den As Double
Value = Trim$(Value)
P = InStr(Value, "/")
If P = 0 Then
N = Val(Value)
Else
Den = Val(Mid$(Value, P + 1))
Value = Trim$(Left$(Value, P - 1))
P = InStr(Value, " ")
If P = 0 Then
Num = Val(Value)
Else
Num = Val(Mid$(Value, P + 1))
N = Val(Left$(Value, P - 1))
End If
End If
If Den <> 0 Then N = N + Num / Den
FractionToNumber = Round(N, Digits)
End Function
You may also code something like the following:
Sub FractionConvertMTO()
Dim rng As Range
Dim Arr As Variant
Arr = Worksheets("MTO").Range("F6:H48")
For Row = 1 To UBound(Arr, 1)
For col = 1 To UBound(Arr, 2)
str1 = Arr(Row, col)
pos1 = InStr(str1, " ")
pos2 = InStr(str1, "/")
If pos2 = 0 Then
N = val(str1)
Num = 0: Den = 1
Else
If pos1 And pos1 < pos2 Then
N = val(Left$(str1, pos1 - 1))
Num = val(Mid$(str1, pos1 + 1))
Else
N = 0
Num = val(Left$(str1, pos2 - 1))
End If
Den = val(Mid$(str1, pos2 + 1))
End If
Arr(Row, col) = N + Num / Den
Next col
Next Row
Worksheets("MTO").Range("F6", "H48") = Arr
End Sub
If you dispose of the newer dynamic array features (vers. 2019+,MS365) you might write the results in one go to the entire original range (target range) as follows (overwriting the existing range; otherwise define a given offset to identify another target range: rng.Offset(,n)=..).
Tip: make a backup copy before testing (as it overwrites rng)!
Note that this example assumes the " character (asc value of 34).
A) First try via tabular VALUE() formula evaluation
Caveat: converting blanks by VALUE() would be written as #VALUE! results, which would need a further loop. To avoid this you can prefix a zero to the formulae myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))" so that results would be displayed as zero.
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) define tabular formula
Dim myFormula As String
'myFormula = "=VALUE(SUBSTITUTE(" & rng.Address & ","""""""",""""))"
'Alternative to avoid #VALUE! displays for blanks:
myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))"
'Debug.Print myFormula
'3) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value2 = rng.Parent.Evaluate(myFormula)
End Sub
Conclusion due to comment:
Though fast, this approach has a big disadvantage: Excel interpretes date-like numbers as such, transforms them internally to dates by returning the numeric part here, so a cell input of 3/4" would return the corresponding date value of the current year for March 4th.
B) Reworked code based on direct cell evaluations in a loop //Edit
Similar to the above processing this approach is also based on evaluation, but collects all formulae as strings in a variant datafield array v, which allows to manipulate and evaluate each cell input individually:
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) assign formula strings to variant 1-based 2-dim data field array
Dim v As Variant
v = rng.Formula2
'3) evaluate results in a loop
Dim i As Long, j As Long
For i = 1 To UBound(v)
For j = 1 To UBound(v, 2)
v(i, j) = Evaluate("0" & Replace(v(i, j), Chr(34), ""))
Next j
Next i
'4) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value = v
End Sub
str1 = trim(Replace(str1, "0.", "."))
I'm trying to compare 2 3-digit numbers. This is my current code using nested Ifs
If Mid(Num1, 1, 1) = Mid(Num2, 1, 1) Then
'Check first number against first number
If Mid(Num1, 2, 1) = Mid(Num2, 2, 1) Then
'Check second number against second number
If Mid(Num1, 3, 1) = Mid(Num2, 3, 1) Then
'Check third number against third number
Digits = 3
Else
Digits = 2
End If
And this is just one small part of it. Also, I need to check the order in which they match as well. So whether it's an exact match, all 3 digits match in any order, or if 1 or 2 digits match in any order.
The problem is I have a lot of If statements using this method as I have to compare every combination of digits to check for a 1 digit, 2 digit, 3 digit, etc, match. Is there a better way?
Can be simplified to a function with a simple for loop
Private Function digitMatch(ByVal num1 as String, ByVal num2 as String) As Byte
' num1 and num2 are strings, because of presumption they can start with 0
' (i.e. 042 is valid 3 digit number format, otherwise they can be integers as well)
Dim i As Byte
Dim matches As Byte: matches = 0
For i = 1 To Len(num1)
If InStr(1, num2, Mid(num1, i, 1)) <> 0 Then
matches = matches + 1
End If
Next i
digitMatch = matches
End Function
so eg. digitMatch(023, 053) would return 2
or digitMatch(123, 321) would return 3
In my answer, I return the digits that match, so you can check if there are any and which ones. Also, it works with any number of digits.
Public Function CheckForMatch(ByVal curNum As String, ByVal winNumber As String) As String
Dim i As Long, j As Long
Dim hit As String
hit = vbNullString
For i = 1 To Len(curNum)
j = InStr(1, winNumber, Mid(curNum, i, 1), vbTextCompare)
If j > 0 Then
hit = hit & Mid(curNum, i, 1)
End If
Next i
CheckForMatch = hit
End Function
Public Sub Test()
Dim check As String
check = CheckForMatch("75214", "13672")
If Len(check) > 0 Then
Debug.Print "Numbers " & check & " are a match."
' 721
Else
Debug.Print "No match. Sorry."
End If
End Sub
NOTE: The use of InStr() here was inspired by the answer Rawplus gave before me.
Try this (it will only work correctly if both 'curNum' and 'WinningNumber' are 3 digits long):
'straight match
If curNum = WinningNumber Then
M = 3
s = 3
'matched the first 2 straight
ElseIf InStr(1, WinningNumber, Left(curNum, 2)) > 0 Then
M = 2
s = 2
If InStr(1, WinningNumber, Right(curNum, 1)) > 0 Then M = M + 1
'matched the last 2 straight
ElseIf InStr(2, WinningNumber, Right(curNum, 2)) > 0 Then
M = 2
s = 2
If InStr(1, WinningNumber, Left(curNum, 1)) > 0 Then M = M + 1
'any other scenario
Else
s = 0
For i = 1 To 3
n = Mid(WinningNumber, i, 1)
If InStr(1, curNum, n) > 0 Then
M = M + 1
End If
Next
End If
Debug.Print "Matched digits: " & M
Debug.Print "Straight: " & s
I'm sure there's a better way to do it but this was the easiest way for me to write it up quickly.
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
For Example,
I'd like a String such as, "This is a Bunch of Words in a sequence of 13 possible 1 words from a Dictionary or BookZZ or Libgen.io 1876" to give me a result of 19 (because "13", "1876" and "1" are numbers and should not be counted).
I created Two Functions which I'm trying to use within this Function I'm asking about:
The first one is the following:
' NthWord prints out the Nth Word of a String of Text in an Excel Cell such
' as A1 or B19.
Function NthWord(ActiveCell As String, N As Integer)
Dim X As String
X = ActiveCell
X = Trim(Mid(Replace(ActiveCell, " ", Application.WorksheetFunction.Rept("
", Len(ActiveCell))), (N - 1) * Len(ActiveCell) + 1, Len(ActiveCell)))
NthWord = X
' In the Excel SpreadSheet:
' Trim (Mid(Substitute(A1, " ", Rept(" ", Len(A1))), (N - 1) * Len(A1)
' + 1, Len(A1)))
End Function
The second one is the following:
'NumberOfWords returns the number of words in a String
Function NumberOfWords(ActiveCell As String)
Dim X As String
X = ActiveCell
Dim i As Integer
i = 0
If Len(Trim(X)) = 0 Then
i = 0
Else:
i = Len(Trim(X)) - Len(Replace(X, " ", "")) + 1
End If
NumberOfWords = i
' In the Excel SpreadSheet
' IF(LEN(TRIM(A1))=0,0,LEN(TRIM(A1))-LEN(SUBSTITUTE(A1," ",""))+1)
End Function
My Attempt at printing the NumberOfNonNumberWords
Function NumberOfNonNumberWords(ActiveCell As String)
Dim X As String
X = ActiveCell
Dim count As Integer
count = 0
Dim i As Integer
If NumberOfWords(X) > 0 Then
For i = 1 To NumberOfWords(X)
If Not (IsNumeric(NthWord(X, i).Value)) Then
count = count + 1
End If
Next i
End If
NumberOfNonNumberWords = count
End Function
However, when I apply this function in the Excel Worksheet, I get an output of
#VALUE!
and I'm not sure why. How do I fix this?
Split the whole string then count non-numeric elements.
function abcWords(str as string) as long
dim i as long, arr as variant
arr = split(str, chr(32))
for i=lbound(arr) to ubound(arr)
abcWords = abcWords - int(not isnumeric(arr(i)))
next i
end function
You could just use SPLIT() to split the text on a space delimiter, then count the non-numeric words:
Function num_words(ByVal text As String)
Dim txt_split
txt_split = Split(text, " ")
Dim total_words As Long
total_words = 0
Dim i As Long
For i = LBound(txt_split) To UBound(txt_split)
If Not IsNumeric(txt_split(i)) Then
total_words = total_words + 1
End If
Next i
num_words = total_words
End Function