Related
Now I'm using MS Excel 2019. I desire to make function to get text at Summary Steps column and Sumary Values column from Steps and Values Column
It's described as .
I tried with this function. However, It doesn't work at all
Function Congdoan_Time(Congdoan As Range, Time As Range, gtri As Boolean) As String
Dim xValue, TimeValue As String
Dim xChar As String
Dim xOutValue, xTimeValue As String
xValue = Congdoan.Value
TimeValue = Time.Value
Dim arr, timearr As Variant
Dim text, texttime As String
Dim nextarr As Variant
arr = Split(xValue, ",")
timearr = Split(TimeValue, "-")
Dim i As Long
Dim vallue As Variant
vallue = timearr(0)
For i = LBound(arr) To UBound(arr) - 1
If arr(i) = arr(i + 1) And i < UBound(arr) - 1 Then
vallue = Val(vallue) + Val(timearr(i + 1))
End If
If arr(i) = arr(i + 1) And i = UBound(arr) - 1 Then
End If
If arr(i) <> arr(i + 1) Then
xOutValue = xOutValue & "," & arr(i)
xTimeValue = xTimeValue & "-" & vallue
vallue = Val(timearr(i + 1))
End If
Next i
If xOutValue = "" Then
xOutValue = Join(arr, ",")
xTimeValue = vallue
End If
text = Right(xOutValue, Len(xOutValue) - 1)
nextarr = Split(text, ",")
If arr(UBound(arr)) <> nextarr(UBound(nextarr)) Then
text = text & "," & arr(UBound(arr))
xTimeValue = xTimeValue & "-" & Val(vallue) + Val(timearr(UBound(arr)))
End If
If gtri = True Then
Congdoan_Time = text
Else
Congdoan_Time = xTimeValue
End If
End Function
Formula at Sumary Steps Column
at Sumary Values Column
Please help to make another funtion that's work for me
Thank you
My two cents using a dictionary:
Function Summary(steps As String, vals As String, pick As Boolean) As String
Dim arr_steps As Variant, arr_vals As Variant
Dim new_steps() As Variant, new_vals() As Variant
arr_steps = Split(steps, ",")
arr_vals = Split(vals, "-")
ReDim new_steps(UBound(arr_steps))
ReDim new_vals(UBound(arr_steps))
For x = 0 To UBound(arr_steps)
If x = 0 Then
new_steps(x) = arr_steps(x)
new_vals(x) = arr_vals(x)
ElseIf arr_steps(x) = arr_steps(x - 1) Then
new_vals(x) = CDbl(new_vals(x - 1)) + CDbl(arr_vals(x))
new_vals(x - 1) = ""
Else
new_steps(x) = arr_steps(x)
new_vals(x) = arr_vals(x)
End If
Next
If pick Then
Summary = Join(new_steps, ",")
Else
Summary = Join(new_vals, "-")
End If
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "(?:^-+|[-,]+([-,])|,+$)"
Summary = .Replace(Summary, "$1")
End With
End Function
Formula in C1:
=Summary(A1,B1,1)
Formula in D1:
=Summary(A1,B1,0)
Note: My locale uses decimal-comma instead of point. It should work out fine if yours is using dots. I just had to change these in the input.
I'm not sure I fully understand the question but looking at your examples it looks like you want to deduplicate a comma delimited string but only where duplicates are in series. Something like this does that quite optimally:
Function SerialDedupe(ByVal s As String) As String
Dim v: v = Split(s, ",")
Dim iLB As Long: iLB = LBound(v)
Dim index As Long: index = iLB
Dim i As Long
For i = iLB + 1 To UBound(v)
If v(i) <> v(index) Then
index = index + 1
v(index) = v(i)
End If
Next
ReDim Preserve v(iLB To index)
SerialDedupe = Join(v, ",")
End Function
Tests:
1,2,2,2,3,3,2 ==> 1,2,3,2
A,B,B,C,B,B,C,D,B,C,B,A,A,B ==> A,B,C,B,C,D,B,C,B,A,B
1,2,2 ==> 1,2
1,1,2 ==> 1,2
1,2 ==> 1,2
1 ==> 1
Using a Macro or Formula, is there a way to achieve the result of the following formula of Office 365?
=FILTER(B:B,A:A = "x")
What it does is get all the values from Column B if Column A on the same row has a value of x.
My PC has office 365 but the one I'm working with only has Office Pro Plus 2019. I had to use my pc when I needed the function and I'm getting tired of it, maybe it can be done on Office Pro Plus 2019 too using a formula or a macro?
Use:
=IFERROR(INDEX($B$1:$B$100,AGGREGATE(15,7,ROW($A$1:$A$100)/($A$1:$A$100="x"),ROW($ZZ1))),"")
Note the use of a set range and not full columns. That is done on purpose, This being an array formula it will do a lot of calculations each cell it is placed. Limiting the range to the data set will speed it up.
Put this in the first cell of the output and copy down till blanks are returned.
I had some spare time and I am recently interested in User defined functions so I decided to make my own version of what I imagine this would be. I'm prefacing this by saying its not good and is excessively long but it works!
Function JOINIF(ByRef IfRange As Range, ByVal Criteria As String, Optional JoinRange As Range, Optional Delimeter As String = ",") As String
'IfRange is the range that will be evaluated by the Criteria
'Criteria is a logical test that can be applied to a cell value.
'Examples of Criteria: "=Steve", ">100", "<>Toronto", "<=-1"
'JoinRange is the range of values that will be concatenated if the corresponding -
'IfRange cell meets the criteria. JoinRange can be left blank if the values to be -
'concatenated are the IfRange values.
'Delimeter is the string that will seperate the concatenated values.
'Default delimeter is a comma.
Dim IfArr() As Variant, JoinArr() As Variant, OutputArr() As String
Dim IfArrDim As Integer, JoinArrDim As Integer
Dim JCount As Long, LoopEnd(1 To 2) As Long
Dim MeetsCriteria As Boolean, Expression As String
Dim i As Long, j As Long
'PARSING THE CRITERIA
Dim Regex As Object
Set Regex = CreateObject("VBScript.RegExp")
Regex.Pattern = "[=<>]+"
'Looking for comparison operators
Dim Matches As Object
Set Matches = Regex.Execute(Criteria)
If Matches.Count = 0 Then
'If no operators found, assume default "Equal to"
If Not IsNumeric(Criteria) Then
'Add quotation marks to allow string comparisons
Criteria = "=""" & Criteria & """"
End If
Else
If Not IsNumeric(Replace(Criteria, Matches(0), "")) Then
Criteria = Matches(0) & """" & Replace(Criteria, Matches(0), "") & """"
End If
'Add quotation marks to allow string comparisons
End If
'Trim IfRange to UsedRange
Set IfRange = Intersect(IfRange, IfRange.Parent.UsedRange)
'Default option for optional JoinRange input
If JoinRange Is Nothing Then
Set JoinRange = IfRange
Else
Set JoinRange = Intersect(JoinRange, JoinRange.Parent.UsedRange)
End If
'DIMENSIONS
'Filling the arrays
If IfRange.Cells.Count > 1 Then
IfArr = IfRange.Value
IfArrDim = Dimensions(IfArr)
Else
ReDim IfArr(1 To 1)
IfArr(1) = IfRange.Value
IfArrDim = 1
End If
If JoinRange.Cells.Count > 1 Then
JoinArr = JoinRange.Value
JoinArrDim = Dimensions(JoinArr)
Else
ReDim JoinArr(1 To 1)
JoinArr(1) = JoinRange.Value
JoinArrDim = 1
End If
'Initialize the Output array to the smaller of the two input arrays.
ReDim OutputArr(IIf(IfRange.Cells.Count < JoinRange.Cells.Count, IfRange.Cells.Count - 1, JoinRange.Cells.Count - 1))
'DEFINING THE LOOP PARAMETERS
'Loop ends on the smaller of the two arrays
If UBound(IfArr) > UBound(JoinArr) Then
LoopEnd(1) = UBound(JoinArr)
Else
LoopEnd(1) = UBound(IfArr)
End If
If IfArrDim = 2 Or JoinArrDim = 2 Then
If Not (IfArrDim = 2 And JoinArrDim = 2) Then
'mismatched dimensions
LoopEnd(2) = 1
ElseIf UBound(IfArr, 2) > UBound(JoinArr, 2) Then
LoopEnd(2) = UBound(JoinArr, 2)
Else
LoopEnd(2) = UBound(IfArr, 2)
End If
End If
'START LOOP
If IfArrDim = 1 Then
For i = 1 To LoopEnd(1)
If IsNumeric(IfArr(i)) And IfArr(i) <> "" Then
Expression = IfArr(i) & Criteria
Else
'Add quotation marks to allow string comparisons
Expression = """" & IfArr(i) & """" & Criteria
End If
MeetsCriteria = Application.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, 1))
End If
JCount = JCount + 1
End If
Next i
Else
For i = 1 To LoopEnd(1)
For j = 1 To LoopEnd(2)
If IsNumeric(IfArr(i, j)) And IfArr(i, j) <> "" Then
Expression = IfArr(i, j) & Criteria
Else
'Add quotation marks to allow string comparisons
Expression = """" & IfArr(i, j) & """" & Criteria
End If
MeetsCriteria = Application.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, j))
End If
JCount = JCount + 1
End If
Next j
Next i
End If
'END LOOP
ReDim Preserve OutputArr(JCount + 1 * (JCount > 0))
JOINIF = Join(OutputArr, Delimeter)
End Function
Private Function Dimensions(var As Variant) As Long
'Credit goes to the great Chip Pearson, chip#cpearson.com, www.cpearson.com
On Error GoTo Err
Dim i As Long, tmp As Long
While True
i = i + 1
tmp = UBound(var, i)
Wend
Err:
Dimensions = i - 1
End Function
Examples of it in use:
Seperate IfRange and JoinRange
IfRange as the JoinRange
You might try the following udf (example call: FILTER2(A1:A100,B1:B100)) consisting of the following tricky steps:
a) Evaluate the general condition (=If(A1:A100="x",Row(A1:A100),"?") as tabular Excel formula and assign all valid row numbers to array x (marking the rest by "?" strings),
b) Filter out all "?" elements
c) Apply x upon the data column benefitting from the advanced restructuring features of Application.Index()
Public Function Filter2(rng1 As Range, rng2 As Variant, Optional ByVal FilterID As String = "x")
Dim a As String: a = rng1.Address(False, False, External:=True)
'a) get all valid row numbers (rng1)
Dim myformula As String: myformula = "if(" & a & "=""" & FilterID & """,row(" & a & "),""?"")"
Dim x: x = Application.Transpose(Evaluate(myformula))
'b) filter out invalid "?" elements
x = VBA.Filter(x, "?", False)
'c) apply x upon data column (rng2)
If UBound(x) > -1 Then Filter2 = Application.Index(rng2, Application.Transpose(x), 1)
End Function
Note that function calls before versions 2019/MS 365 need to be entered as array formula (Ctrl+Shift+Enter).
The function assumes one-column (range) arguments.
Edit due to comment as of 2022-06-08
The whole example is based on the actual row numbers starting in the first row (OP ranges refer to A:A,B:B. If you want to allow ranges to start at any row, you'd need to change the myFormula definition in section a) by correcting the row indices by subtracting possible offsets (row number + 1 - first row):
Dim myFormula As String
myFormula = "if(" & a & "=""" & FilterID & """,row(" & a & ")+1 -" & rng1.Row & ",""?"")"
Try this UDF for the Filter Function:
Function FILTER_HA(Where, Criteria, Optional If_Empty) As Variant
Dim Data, Result
Dim i As Long, j As Long, k As Long
'Create space for the output (same size as input cells)
With Application.Caller
i = .Rows.Count
j = .Columns.Count
End With
'Clear
ReDim Result(1 To i, 1 To j)
For i = 1 To UBound(Result)
For j = 1 To UBound(Result, 2)
Result(i, j) = ""
Next
Next
'Count the rows to show
For i = 1 To UBound(Criteria)
If Criteria(i, 1) Then j = j + 1
Next
'Empty?
If j < 1 Then
If IsMissing(If_Empty) Then
Result(1, 1) = CVErr(xlErrNull)
Else
Result(1, 1) = If_Empty
End If
GoTo ExitPoint
End If
'Get all data
Data = Where.Value
'Copy the rows to show
For i = 1 To UBound(Data)
If Criteria(i, 1) Then
k = k + 1
For j = 1 To UBound(Data, 2)
Result(k, j) = Data(i, j)
Next
End If
Next
'Return the result
ExitPoint:
FILTER_HA = Result
End Function
I have the following Excel sheet which has random number combinations build using numbers from 2 to 50 in set of 3, 2 and 1 in Column A.
I am trying to build whole possible combinations between Column A elements such that the obtained combination doesn't have any repeating numbers in them and contains all the number from 2 to 50.
My current code starts from A2 and builds only a single combination set. It doesn't evaluate other possible combinations with starting element as in A2, it then goes to A3 and then builds only one combination set using A3. This step continues for A4,A5...
This is my current code.
Private Sub RP()
Dim lRowCount As Long
Dim temp As String, s As String
Dim arrLength As Long
Dim hasElement As Boolean
Dim plans() As String, currentPlan() As String
Dim locationCount As Long
Dim currentRoutes As String
Dim line As Long
Worksheets("Sheet1").Activate
Application.ActiveSheet.UsedRange
lRowCount = ActiveSheet.UsedRange.Rows.Count
locationCount = -1
line = 2
Debug.Print ("*********")
For K = 2 To lRowCount - 1
currentRoutes = ""
For i = K To lRowCount
s = ActiveSheet.Cells(i, 1)
Do
temp = s
s = Replace(s, " ", "")
Loop Until temp = s
currentPlan = Split(Trim(s), ",")
arrLength = UBound(currentPlan) - LBound(currentPlan) + 1
hasElement = False
If Len(Join(plans)) > 0 Then
For j = 0 To arrLength - 1
pos = Application.Match(currentPlan(j), plans, False)
If Not IsError(pos) Then
hasElement = True
Exit For
End If
Next j
End If
If Not hasElement Then
currentRoutes = currentRoutes & (Join(currentPlan, ",")) & " "
If Len(Join(plans)) > 0 Then
plans = Split(Join(plans, ",") & "," & Join(currentPlan, ","), ",")
Else
plans = currentPlan
End If
End If
Next i
If locationCount < 0 Then
locationCount = UBound(plans) - LBound(plans) + 1
End If
If (UBound(plans) - LBound(plans) + 1) < locationCount Then
Debug.Print ("Invalid selection")
Else
Debug.Print (Trim(currentRoutes))
Worksheets("Sheet1").Cells(line, 11) = currentRoutes
line = line + 1
End If
Erase plans
Debug.Print ("*********")
Next K
End Sub
I've been looking for a while for a code that would give me the digits between without using regex (I want my macro to be used by anyone especially non-computer friendly people). This is a small part of a code creating series for a chart dynamically creating the chart etc.
Here is the type of data I am dealing with "C23H120N5O4Cl" so I'd like to save in a variable 23 then in another one 120 the rest should not matter (it could be nothing).
My digits will likely be between single characters (C,H,or else) but I need the numbers after C and H. So at the moment here is my code :
RangeOccupied = Range("C2").End(xlDown).row
For i = 1 To RangeOccupied
If i <> RangeOccupied Then
'Look for digits after C
pos = InStr(1, Cells(i + 1, 2), "C") + 1
pos1 = InStr(pos, Cells(i + 1, 2), "H")
NumC = Mid(Cells(i + 1, 2), pos, pos1 - pos)
'Look for digits after H
pos = InStr(1, Cells(i + 1, 2), "H") + 1
pos1 = InStr(pos, Cells(i + 1, 2), "O")
NumH = Mid(Cells(i + 1, 2), pos, pos1 - pos)
End If
Next
Ideally I'd like the pos1 numbers not to be dependent on a specific character but any character. i.e having pos1=InStr(pos,Cells(i+1,2),"ANY NON-NUMBER CHARACTER").
I do not know if it is possible without using regex.
This function will return an array of the digit strings in a text string
Option Explicit
Function myDigits(str As String) As String()
Dim col As Collection
Dim I As Long, S() As String
I = 0
Set col = New Collection
Do Until I > Len(str)
I = I + 1
If IsNumeric(Mid(str, I, 1)) Then
col.Add Val(Mid(str, I, Len(str)))
I = I + 1
Do Until Not IsNumeric(Mid(str, I, 1))
I = I + 1
Loop
End If
Loop
ReDim S(0 To col.Count - 1)
For I = 1 To col.Count
S(I - 1) = col(I)
Next I
myDigits = S
End Function
Okay, I'm absolutely certain there is a more efficient way of doing this. But I think the following example makes it fairly clear on one way to separate your values.
Option Explicit
Sub test()
Dim testValues() As String
Dim val1 As Long
Dim val2 As Long
testValues = Split("C23H120N5O4Cl,C23O120N5H4Cl,C4H120", ",")
Dim testValue As Variant
For Each testValue In testValues
ExtractValues testValue, val1, val2
Debug.Print "For " & testValue & ": " & val1 & " and " & val2
Next testValue
End Sub
Public Sub ExtractValues(ByVal inString As String, _
ByRef output1 As Long, _
ByRef output2 As Long)
Dim outString1 As String
Dim outString2 As String
Dim stage As String
stage = "Begin"
Dim thisCharacter As String
Dim i As Long
For i = 1 To Len(inString)
thisCharacter = Mid$(inString, i, 1)
Select Case stage
Case "Begin"
If thisCharacter = "C" Then stage = "First Value"
Case "First Value"
If (Asc(thisCharacter) >= Asc("0")) And _
(Asc(thisCharacter) <= Asc("9")) Then
outString1 = outString1 & thisCharacter
Else
'--- if we get here, we're done with this value
output1 = CLng(outString1)
'--- verify the next character is the "H"
If thisCharacter = "H" Then
stage = "Second Value"
Else
stage = "Next Value"
End If
End If
Case "Next Value"
If thisCharacter = "H" Then stage = "Second Value"
Case "Second Value"
If (Asc(thisCharacter) >= Asc("0")) And _
(Asc(thisCharacter) <= Asc("9")) Then
outString2 = outString2 & thisCharacter
Else
'--- if we get here, we're done with this value
output2 = CLng(outString2)
stage = "Finished"
Exit For
End If
End Select
Next i
If Not (stage = "Finished") Then
output2 = CLng(outString2)
End If
End Sub
Here's another method that's more generic and efficient than my first solution. This approach uses a function to extract the number following a given substring -- in this case it's a single letter "C" or "H". The function accounts for the value being at the end of the input value as well.
Option Explicit
Sub test()
Dim testValues() As String
Dim val1 As Long
Dim val2 As Long
testValues = Split("C23H120N5O4Cl,C23O120N5H4Cl,C4H120", ",")
Dim testValue As Variant
For Each testValue In testValues
val1 = NumberAfter(testValue, "C")
val2 = NumberAfter(testValue, "H")
Debug.Print "For " & testValue & ": " & val1 & " and " & val2
Next testValue
End Sub
Private Function NumberAfter(ByVal inString As String, _
ByVal precedingString As String) As Long
Dim outString As String
Dim thisToken As String
Dim foundThisToken As Boolean
foundThisToken = False
Dim i As Long
For i = 1 To Len(inString)
thisToken = Mid$(inString, i, 1)
If thisToken = precedingString Then
foundThisToken = True
ElseIf foundThisToken Then
If thisToken Like "[0-9]" Then
outString = outString & thisToken
Else
Exit For
End If
End If
Next i
NumberAfter = CLng(outString)
End Function
I found this solution from here Extract numbers from chemical formula
Public Function ElementCount(str As String, element As String) As Long
Dim i As Integer
Dim s As String
For i = 1 To 3
s = Mid(str, InStr(str, element) + 1, i)
On Error Resume Next
ElementCount = CLng(s)
On Error GoTo 0
Next i
End Function
Which works but if simple molecules like CH4 are put in it does not work since no number are shown... but I (we) can probably work that out.
Thanks again for all the solutions !
EDIT:
Here is the function I use that I think takes all possible scenarios into account ! Thanks again for your help !
Public Function ElementCount(str As String, element As String) As Long
Dim k As Integer
Dim s As String
For k = 1 To Len(str)
s = Mid(str, InStr(str, element) + 1, k)
On Error Resume Next
ElementCount = CLng(s)
On Error GoTo 0
If InStr(str, element) > 0 And ElementCount = 0 Then
ElementCount = 1
End If
Next k
End Function
EDIT
Changed the function to use and return dictionaries having keys of "C" and "H" paired with their numbers. Included a screenshot below.
Made sure it handles for tricky situations where multiple letters are packed ontop of each other:
Code:
Sub mainLoop()
Dim numbers As Scripting.Dictionary: Set numbers2 = New Scripting.Dictionary
For i = 1 To 5
Set numbers = returnDict(Cells(i, 1).Value)
printout numbers, i
Next
End Sub
Function returnDict(cellValue As String) As Scripting.Dictionary
Dim i As Integer: i = 1
Dim holder As String: holder = ""
Dim letter As String
Set returnStuff = New Scripting.Dictionary
While i < Len(cellValue)
If Mid(cellValue, i, 1) = "C" Or Mid(cellValue, i, 1) = "H" Then
i = i + 1
If IsNumeric(Mid(cellValue, i, 1)) Then
letter = (Mid(cellValue, i - 1, 1))
Do While IsNumeric(Mid(cellValue, i, 1))
holder = holder & Mid(cellValue, i, 1)
i = i + 1
If i > Len(cellValue) Then Exit Do
Loop
returnStuff.Add letter, holder
holder = ""
ElseIf Mid(cellValue, i, 1) <> LCase(Mid(cellValue, i, 1)) Then
returnStuff.Add Mid(cellValue, i - 1, 1), "1"
End If
Else
i = i + 1
End If
Wend
End Function
And heres a quick little function used to print out the contents of the dictionary
Sub printout(dict As Scripting.Dictionary, row As Integer)
Dim i As Integer: i = 2
For Each Key In dict.Keys
Cells(row, i).Value = Key & ": " & dict.Item(Key)
i = i + 1
Next
End Sub
My 2c:
Sub tester()
Dim r, arr, v
arr = Array("C", "Z", "Na", "N", "O", "Cl", "Br", "F")
For Each v In arr
Debug.Print v, ParseCount("C15H12Na2N5O4ClBr", v)
Next v
End Sub
Function ParseCount(f, s)
Const ALL_SYMBOLS As String = "Ac,Al,Am,Sb,Ar,As,At,Ba,Bk,Be,Bi,Bh,Br,Cd,Ca,Cf,Ce,Cs,Cl," & _
"Cr,Co,Cn,Cu,Cm,Ds,Db,Dy,Es,Er,Eu,Fm,Fl,Fr,Gd,Ga,Ge,Au,Hf,Hs,He,Ho,In,Ir,Fe,Kr,La,Lr," & _
"Pb,Li,Lv,Lu,Mg,Mn,Mt,Md,Hg,Mo,Mc,Nd,Ne,Np,Ni,Nh,Nb,No,Og,Os,Pd,Pt,Pu,Po,Pr,Pm,Pa,Ra," & _
"Rn,Re,Rh,Rg,Rb,Ru,Rf,Sm,Sc,Sg,Se,Si,Ag,Na,Sr,Ta,Tc,Te,Ts,Tb,Tl,Th,Tm,Sn,Ti,Xe,Yb,Zn," & _
"Zr,B,C,F,H,I,N,O,P,K,S,W,U,V,Y"
Dim atoms, rv, pos, i As Long
atoms = Split(ALL_SYMBOLS, ",")
rv = 0 'default return value
If IsError(Application.Match(s, atoms, 0)) Then
rv = -1 'not valid atomic symbol
Else
i = 1
pos = InStr(i, f, s, vbBinaryCompare)
If pos > 0 Then
If Len(s) = 2 Then
'should be a true match...
rv = ExtractNumber(f, pos + 2)
ElseIf Len(s) = 1 Then
'check for false positives eg "N" matches on "Na"
Do While pos > 0 And Mid(f, pos + 1, 1) Like "[a-z]"
i = pos + 1
pos = InStr(i, f, s, vbBinaryCompare)
Loop
If pos > 0 Then rv = ExtractNumber(f, pos + 1)
Else
'exotic chemistry...
End If
End If
End If
ParseCount = rv
End Function
'extract consecutive numeric digits from f starting at pos
' *returns 1 if no number present*
Function ExtractNumber(f, pos)
Dim rv, s, i As Long
Do While (pos + i) <= Len(f)
If Not Mid(f, pos + i, 1) Like "#" Then Exit Do
i = i + 1
Loop
ExtractNumber = IIf(i = 0, 1, Mid(f, pos, i))
End Function
I am facing problem when receiving a long message as below
40=1.22.50=0.002.60=35.
The system use the dot as separator while there is also decimal values for numeric value.
The desired output is
40=1.22
50=0.002
60=35
I am now using manual way to format the message. Hope to have a better way to overcome this.
Assuming you have one dot "." as the decimal position, and another "." that separates each element in the array. You can use the code below to read all values of the Long string into an array (Nums is the name of the array).
Option Explicit
Sub Seperate_DecimNumbers()
Dim Nums As Variant
Dim FullStr As String
Dim DotPosition As Integer
Dim i As Integer
' init array size to a large size , will redim it at the end to number of elements found
ReDim Nums(1 To 100)
FullStr = "40=1.22.50=0.002.60=35."
i = 1 ' init array elements counter
Do Until Len(FullStr) = 0
' call FindN function , searching for the 2nd "."
DotPosition = FindN(FullStr, ".", 2)
' unable to find 2 "." in the string >> last element in the array
If DotPosition = 0 Then
Nums(i) = FullStr
Exit Do
Else ' was able to find 2 "." in the string
Nums(i) = Left(FullStr, DotPosition - 1)
End If
i = i + 1
FullStr = Right(FullStr, Len(FullStr) - DotPosition)
Loop
' redim array back to maximum of numbers found in String
ReDim Preserve Nums(1 To i)
' place output start location from Range A2 and below (till number of elements in the array)
Range("A1").Offset(1, 0).Resize(UBound(Nums), 1).Value = Application.Transpose(Nums)
End Sub
Function FindN(sInputString As String, sFindWhat As String, N As Integer) As Integer
' this function find the Nth position of a certain character in a string
Dim J As Integer
Application.Volatile
FindN = 0
For J = 1 To N
FindN = InStr(FindN + 1, sInputString, sFindWhat)
If FindN = 0 Then ' unable to find the 2nd "." >> last appearance
Exit For
End If
Next
End Function
See result below:
Here's my take on the answer, which splits things on the = rather than the .. Doing it this way allows for input such as 40=1.22.50=0.002.60=35.70=120. (i.e. the part to the right of an = does not have to contain a ., it could be an integer.)
Sub SplitDotEqual()
Dim s As String
Dim a() As String
Dim i As Integer
Dim d As Integer
'Read from A1
s = Range("A1").Value
'Split on the "="
a = Split(s & ".", "=") ' include an extra "." to ensure that
' the final field is ended
For i = 0 To UBound(a) - 1
'Put the "=" back
a(i) = a(i) & "="
'Find the last "." before the next "="
d = InStrRev(a(i + 1), ".")
'Append everything prior to the "."
a(i) = a(i) & Left(a(i + 1), d - 1)
'Write to A2:Ax
Cells(i + 2, 1).Value = a(i)
'Strip off everything prior to the ".",
'leaving just the stuff prior to the "="
a(i + 1) = Mid(a(i + 1), d + 1)
Next
End Sub
Let's assume that every other dot is a separator. This code changes the odd-numbered dots into pipes and then parses on the pipes:
Sub parser()
Dim FlipFlop As Boolean, dot As String, pipe As String
Dim s As String, L As Long, i As Long, CH As String
dot = "."
pipe = "|"
s = Range("A1").Value
L = Len(s)
FlipFlop = True
For i = 1 To L
CH = Mid(s, i, 1)
If CH = dot Then
If FlipFlop Then
Else
Mid(s, i, 1) = pipe
End If
FlipFlop = Not FlipFlop
End If
Next i
msg = s & vbCrLf
ary = Split(s, pipe)
For Each a In ary
msg = msg & vbCrLf & a
Next a
MsgBox msg
End Sub
got more closer message and the code partially works.
8=TEST.1.2.9=248.35=D.49=MMUIJ.56=FGTUH.34=32998.50=MMTHUJ.57=AY/ABCDE.52=20161216-07:58:07.11=00708991.1=A-12345-