I need help in solving the problem:
Formula in Excel cell is like this-> =20000-17000+1000 , I need to split the figures in different columns like this-> 20000 | 17000 | 1000 , no problem with removing + / -, I can live without them. Unable to find any help hence posted here.
Thanking in advance.example given
CTR+H and change sign - into whatever unique like # then replace + the same way into #.
After having 20000#17000#1000use:
Data/Text to columns/Delimited/Other and type #
You may record a macro to have it automated.
This Sub can do it:
Public Sub SplitSum(rngInput As Range, rngOutputStart As Range)
Dim varParts As Variant: varParts = Split(Replace(Replace(Mid(rngInput.Formula, 2), "-", "|"), "+", "|"), "|")
Dim c As Long: For c = LBound(varParts) To UBound(varParts)
rngOutputStart.offset(0, c - LBound(varParts)).Value = CDbl(varParts(c))
Next c
End Sub
You can use it like this:
SplitSum ActiveCell, ActiveCell.Offset(0, 1)
This function will preserve the sign before your numbers and has been written simply so as to permit you easy access for further tweaking if necessary.
Sub SumsToColumns(Rng As Range)
Dim RngVal As String
Dim Vals() As String
Dim n As Integer
RngVal = Trim(Rng.Cells(1).Formula)
If Len(RngVal) Then
RngVal = Mid(Replace(RngVal, "+ ", "+"), 2)
RngVal = Replace(RngVal, " +", " +")
RngVal = Replace(RngVal, "- ", "-")
RngVal = Replace(RngVal, "-", " -")
Do
n = Len(RngVal)
RngVal = Replace(RngVal, " ", " ")
Loop While Len(RngVal) < n
Vals = Split(RngVal)
For n = 0 To UBound(Vals)
With Rng
.Worksheet.Cells(.Row, .Column + n + 2).Value = Vals(n)
End With
Next n
End If
End Sub
You can call this function with a line like this:-
SumsToColumns(Range("G13"))
where "G13" is a range you might extract from a simple procedure that loops through all cells in a column. Please take note of the following line in the code.
.Worksheet.Cells(.Row, .Column + n + 2).Value
It specifies that the result should be written in the same worksheet as where the Range("G13") was taken from, in the same row (13 in this case) and starting 2 columns to the right, in this case "G" + 2 columns = "I". You can modify the "2" to any offset you might require. The result will be split over as many columns as there are separate numbers in G13.
Related
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 need a bit of help with a small project. I just started VBA and I think I could use learning to optimise my code.
Cell A2, contains a text with many email address separated by ",". I managed to extract all the email addresses but I think I made too much use of cells, and I was wondering if you can help me reduce that and use the variables defined instead.
Screenshot of the working code
Sub fpor()
Dim Text As String
Dim full As Integer
Dim i As Integer
Dim e As Integer
Dim part As String
Dim part_len As Integer
Dim part_a As Integer
Dim Text_2 As String
x = 5
ActiveCell = Range("A2")
Text = Range("A2")
full = Len(Text)
'full = InStrRev(Text, ",")
For i = 1 To full
Cells((x + i), 1).Value = Text
part = InStr(Text, ",")
Cells((x + i), 2).Value = part
Cells((x + i), 3) = Left(Text, part)
Cells((x + i), 4) = full - part
Text = Right(Cells((x + i), 1), Cells((x + i), 4))
If part = 0 Then
full = 0
Cells((x + i), 3) = Text
Exit For
Else:
full = Len(Text)
End If
Next i
MsgBox (full)
MsgBox (part)
End Sub `
How do you think I can better optimise the For Loop?
Thank you all for your answers you awesome people : )
you can greatly simplify your code with the use of Split() Function as follows:
Option Explicit
Sub fpor()
Dim emailsArr As Variant
With Worksheets("emails") '<--change "emails" with your actual sheet name
emailsArr = Split(.Range("a2"), ",") '<--| split all emails names delimited by a ',' into an array
.Range("A6").Resize(UBound(emailsArr)).value = Application.Transpose(emailsArr) '<--| write array content from cell A6 downwards
End With
End Sub
I have a columns of strings as follows. How can I put the symbol '<' in between the characters ?
'ABCDE'
'BCG'
'ABCD'
The expected output should be:
A<B<C<D<E
B<C<G
A<B<C<D
=concatenate(left(A1,1),"<",mid(A1,2,1),"<",mid(A1,3,1),(if(len(A1)>3,"<"&mid(A1,4,1)&if(len(A1)>4,"<"&mid(A1,5,1),""),"")))
Will do what you want for values up to 5 letters, and as few as 3 letters. Otherwise you can change it.
Basically it adds a "<" between the first 3 letters and then checks whether the string is longer than 3 letters and if so, adds more "<" characters. If this needs to be more dynamic it's far easier in vba.
A manual, one-off, no-VBA approach would be:
use the Text to Columns tool with Fixed Width and place the markers after each character.
then use a formula like this to append values and separator
The formula could look like this if your values are in row 1
=A1&IF(LEN(B1)>0,">"&B1,"")&IF(LEN(C1)>0,">"&C1,"")&IF(LEN(D1)>0,">"&D1,"")&IF(LEN(E1)>0,">"&E1,"")
Adjust formula to suit the maximum number of characters in a cell.
Such things are not for formulas...
As you tag question as Excel-VBA too, so:
'''''''
Private Sub sb_Test_fp_AddSym()
Debug.Print fp_AddSym("abncd", "<")
End Sub
Public Function fp_AddSym(pStr$, pSym$) As String
Dim i&, j&, iLB&, iUBs&, iUBt&
Dim tSrc() As Byte, tTgt() As Byte, tSym As Byte
tSrc = pStr
tSym = Asc(pSym)
iLB = LBound(tSrc)
iUBs = UBound(tSrc)
iUBt = iUBs * 2 + 3
ReDim tTgt(iLB To iUBt)
For i = iLB To iUBs Step 2
j = i * 2
tTgt(j) = tSrc(i)
tTgt(j + 1) = tSrc(i + 1)
tTgt(j + 2) = tSym
tTgt(j + 3) = 0
Next
ReDim Preserve tTgt(iLB To (iUBt - 4))
Debug.Print tTgt
Stop
fp_AddSym = tTgt
End Function
'''
This worked for me:
Sub SymbolInsert()
Dim cl As Range, temp As String
For Each cl In Range("A1:A3") '~~~> Define your range here
For i = 1 To Len(cl)
temp = temp & Mid(cl, i, 1) & "<"
Next i
cl = IIf(VBA.Right$(temp, 1) = "<", VBA.Left$(temp, Len(temp) - 1), temp)
temp = vbNullString
Next cl
End Sub
It can probably be done with Excel formula for any length, but here is the shortest VBA solution
For Each c In Range("A:A").SpecialCells(xlCellTypeConstants)
c.Value2 = Replace( Left$( StrConv( c, vbUnicode), Len(c) * 2 - 1), vbNullChar, "<")
Next
How can I set up a macro that will strip the letters from #####XX in column I and put them in to column L same row? Thanks!
Assuming you're working with the first sheet and you're always stripping off the last two characters while leaving the first 5 characters, the following code will work:
Public Sub StripOff()
Dim iRow as Integer
iRow = 2 'Assuming row 1 is headers, else make this 1
While Sheets(1).Range("I" + Cstr(iRow)).Value <> ""
Sheets(1).Range("L" + CStr(iRow)).Value = Right(Sheets(1).Range("I" + Cstr(iRow)).Value, 2)
Sheets(1).Range("I" + Cstr(iRow)).Value = Left(Sheets(1).Range("I" + Cstr(iRow)).Value, 5)
iRow = iRow + 1
Wend
End Sub
The operative words I'm understanding from your question are Cutting and strip. To my mind, this means that the last two letters are permanently removed from column I and placed in column L.
Sub cut2right()
Dim v As Long, vPFXS As Variant, vSFXS As Variant
With Worksheets("Sheet6")
vPFXS = .Range(.Cells(2, "I"), .Cells(Rows.Count, "I").End(xlUp))
ReDim vSFXS(1 To UBound(vPFXS), 1 To 1)
For v = LBound(vPFXS, 1) To UBound(vPFXS, 1)
If Len(vPFXS(v, 1)) > 1 Then
vSFXS(v, 1) = Right(vPFXS(v, 1), 2)
vPFXS(v, 1) = Left(vPFXS(v, 1), Len(vPFXS(v, 1)) - 2)
End If
Next v
.Cells(2, "I").Resize(UBound(vPFXS, 1), 1) = vPFXS
.Cells(2, "L").Resize(UBound(vPFXS, 1), 1) = vSFXS
End With
End Sub
Working with variant arrays should speed up working with many cells with variable length string values. If they were all the same length then manually running a Text-to-Columns command with a fixed length to an unused column and then copying and pasting the results to the appropriate column would have done just fine.
You can get the leading numeric characters from a string using the VBA Val function. To use this function on a worksheet you will need to create a User Defined Function (UDF) in a standard VBA module.
Function LeadingNumbers(Str As String) As Double
LeadingNumbers = Val(Str)
End Function
Simply enter the function in a cell and reference the cell containing the string you want "cleaned".
I am hoping someone could help me out with a VBA Excel macro.
I have received a worksheet in Excel 2007 which contains product names in one column, and I need to sort this into a logical format so I can use it. However, the list itself is not in any kind of logical order, is 10 000 rows long and I am going to have to do this every month!!
Basically, what I would like to do is search for certain keywords which are common to most of the entries and move them into separate cells in different columns (but in the same row as the original entry).
Regarding keywords: There are 3 different types, two of which I have a complete list of.
Example of keywords: some are measures such as cm (centimetre), mm (millimetre), m (metre) etc.). Then there are other keywords such as % and finally a last set of keywords which is wood, plastic, glass etc.
If this was not complicated enough, the measures (cm for example) are duplicated in some instances and are important details so I cant just separate them but would ideally like them in two adjacent cells.
Fortunately, there is a space after each measure, % sign and item material.
Working from right to left is the easiest way I can think of achieving this as the first description in the string varies wildly between entries and that can stay as is.
So, below is an example string, lets say this is in Cell A1. (Inverted commas are not included in the string and the word "by" appears in only about 100 cases. Usually it is missing...)
"Chair Leg Wood 100% 1m by 20cm"
I would ideally like for the string to be split up into cells as follows
Cell B1 - Chair Leg
Cell C1 - Wood
Cell D1 - 1m
Cell E1 - 2cm
Cell F1 - 100%
Having the % measures in the same column would be extremely helpful
Can anyone please help me with this or the beginnings of a macro which does this and then moves down the list - I have tried using some basic "find" and "len" formulas but really am at my wits end on how to deal with this!
The task boils down to defining a robust definition of the structure of the input data.
Form the info provided a candidate definition might be
<Description, one or more words> <Material, one word> <A value followd by %> <Dimension A> <optional "by"> <Dimension B>
The following macro will process data that conforms this this spec. The definition may need
expanding, eg two word materials (eg Mild Steel)
You will need to add error handling in case any rows don't conform, eg no % in the string, or % character elsewhere in string
Option Explicit
Dim dat As Variant
Sub ProcessData()
Dim r As Range
Dim i As Long
Set r = Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns(1)).Resize(, 5)
dat = r
For i = 1 To UBound(dat, 1)
ParseRow i, CStr(dat(i, 1))
Next
r = dat
ActiveSheet.Columns(5).Style = "Percent"
End Sub
Sub ParseRow(rw As Long, s As String)
'Chair Leg Wood 100% 1m by 20cm
Dim i As Long
Dim sDim As String, sPCnt As String, sMat As String, sDesc As String
Dim sA As String, sB As String
i = InStr(s, "% ")
sDim = Trim(Replace(Mid(s, i + 2), " by ", " ")) ' text to right of %, remove "by"
sA = Trim(Left(sDim, InStr(sDim, " "))) ' split dimension string in two
sB = Trim(Mid(sDim, InStr(sDim, " ")))
s = Left(s, i)
i = InStrRev(s, " ")
sPCnt = Mid(s, i + 1) ' text back to first space before %
s = Trim(Left(s, i))
i = InStrRev(s, " ") ' last word in string
sMat = Mid(s, i + 1)
sDesc = Trim(Left(s, i)) ' whats left
dat(rw, 1) = sDesc
dat(rw, 2) = sMat
dat(rw, 3) = sA
dat(rw, 4) = sB
dat(rw, 5) = sPCnt
End Sub
First, I'd use the Split function to separate the parts into an array, this will avoid most of the string functions and string math:
Dim parts As Variant
parts = Split(A1)
Then, I'd do my comparisons to each part.
Finally, I'd concatenate the parts I didn't breakout, and place all parts on the sheet.
This is based on your example which has spaces inbetween every part, though something similar could work otherwise, you just have to do more work with each part.
Here's my stab at it. We could use about 10 more examples, but this should be a start. To use, select a one column range with your descriptions and run SplitProduct. It will split it out to the right of each cell.
Sub SplitProducts()
Dim rCell As Range
Dim vaSplit As Variant
Dim i As Long
Dim aOutput() As Variant
Dim lCnt As Long
Const lCOLDESC As Long = 1
Const lCOLMAT As Long = 2
Const lCOLPCT As Long = 3
Const lCOLREM As Long = 4
If TypeName(Selection) = "Range" Then
If Selection.Columns.Count = 1 Then
For Each rCell In Selection.Cells
'split into words
vaSplit = Split(rCell.Value, Space(1))
ReDim aOutput(1 To 1, 1 To 1)
'loop through the words
For i = LBound(vaSplit) To UBound(vaSplit)
Select Case True
Case IsPercent(vaSplit(i))
'percents always go in the same column
lCnt = lCOLPCT
If UBound(aOutput, 2) < lCnt Then
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
End If
aOutput(1, lCnt) = vaSplit(i)
Case IsInList(vaSplit(i))
'list items always go in the same column
lCnt = lCOLMAT
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
If UBound(aOutput, 2) < lCnt Then
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
End If
aOutput(1, lCnt) = vaSplit(i)
Case IsMeasure(vaSplit(i))
'measurements go in the last column(s)
If UBound(aOutput, 2) < lCOLREM Then
lCnt = lCOLREM
Else
lCnt = UBound(aOutput, 2) + 1
End If
ReDim Preserve aOutput(1 To 1, 1 To lCnt)
aOutput(1, lCnt) = vaSplit(i)
Case Else
'everything else gets concatentated in the desc column
aOutput(1, lCOLDESC) = aOutput(1, lCOLDESC) & " " & vaSplit(i)
End Select
Next i
'remove any extraneous spaces
aOutput(1, lCOLDESC) = Trim(aOutput(1, lCOLDESC))
'write the values to the left of the input range
rCell.Offset(0, 1).Resize(1, UBound(aOutput, 2)).Value = aOutput
Next rCell
Else
MsgBox "Select a one column range"
End If
End If
End Sub
Function IsPercent(ByVal sInput As String) As Boolean
IsPercent = Right$(sInput, 1) = "%"
End Function
Function IsInList(ByVal sInput As String) As Boolean
Dim vaList As Variant
Dim vaTest As Variant
'add list items as needed
vaList = Array("Wood", "Glass", "Plastic")
vaTest = Filter(vaList, sInput)
IsInList = UBound(vaTest) > -1
End Function
Function IsMeasure(ByVal sInput As String) As Boolean
Dim vaMeas As Variant
Dim i As Long
'add measurements as needed
vaMeas = Array("mm", "cm", "m")
For i = LBound(vaMeas) To UBound(vaMeas)
'any number of characters that end in a number and a measurement
If sInput Like "*#" & vaMeas(i) Then
IsMeasure = True
Exit For
End If
Next i
End Function
No guarantees that this will be speedy on 10k rows.