I'm trying to create a function that calculates Drawdown.
It would work as follows:
I have a series of quotes for a specific stock in column B: B (example)
I want to know the maximum drawdown, that is, how much would be the biggest decrease in the quote.
In this case the biggest indentation occurs in the yellow area!that is, the formula would look like: Drawdown = (MaxValue/Value)-1 ==> Drawdown = (13/9)-1
I tried as follows, with no result:
Public Function MDD(ByVal Selection0, ByVal Selection1)
'Function Max DrawDown
Dim i As Long
Dim Drawdown0 As Long
Dim Drawdown1 As Long
i = 2
Drawdown0 = "(" & Selection0 & "/MAX(" & Selection1 & ")) - 1"
While i < Plan1.Range("B" & Rows.Count).End(xlUp).Row + 1
Drawdown1 = "(" & Selection0 & "/MAX(" & Selection1 & ")) - 1"
If Drawdown1 > Drawdown0 Then
Drawdown0 = Drawdown1
End If
i = i + 1
Wend
MDD = Drawdown0
End Function
Sub lsMDD()
Application.MacroOptions Macro:="MDD", Category:=4
End Sub
Where's the error?
You don't need to iterate over the range. Look at Application.WorksheetFunction - it's got everything you need.
Public Function MDD(ByVal pRange As Variant) As Variant
MDD = Application.WorksheetFunction.Max(pRange) / Application.WorksheetFunction.Min(pRange) - 1
End Function
Related
I am trying to exclude all zero values from my standard deviation calculations. For instance, if my data range has three numbers: 0,1,2 then I only want to calculate the standard deviation of 1 and 2.
Here is my current code (for reference- the top portion of my code is being used to reference certain cell names, that way the ensuing data is properly pulled):
Sub DownsideSTDVCalc()
Dim fund As String
Dim checkFund
Dim item As String
fund = Worksheets(12).Range("A2").Value
For i = 2 To 48
checkFund = Worksheets(11).Columns(i)
item = Worksheets(11).Columns(i).Cells(1, 1)
If item = fund Then
Dim values
Dim qtd
values = Worksheets(11).Range(Worksheets(11).Cells(2, i), Worksheets(11).Cells(4, i))
For j = 1 To UBound(values) - LBound(values)
values(j, 1) = values(j, 1)
Next
qtd = Application.WorksheetFunction.StDev_S(values)
Worksheets(12).Range("b2").Value = qtd
End If
Next
End Sub
For example:
Sub Tester()
Debug.Print StdDevNoZero(Selection)
End Sub
Function StdDevNoZero(rng As Range)
Dim f, addr
addr = rng.Address(False, False)
f = "STDEV.S(IF(" & addr & ">0," & addr & "))"
StdDevNoZero = rng.Parent.Evaluate(f)
End Function
I want to loop thru an array and extract its delimited values that match every date in a range. For e.g., in the picture below:
I have a date range, say 01-01 to 01-10.
I also have a list of strings (see second pic).
In the array below (see first pic), I have three different values delimited by a semi-colon.
For all matching strings (from second pic) e.g., SISBTXTRPR-(number) and date, I want to extract the last part of the array value.
Picture 1
Picture 2
So, for all array values that match "SISBTXTRPR-4649" (the string from picture 2) and a date (in this case 12-12), I want to extract "2h" from the array. The date range for each string, in this case, "SISBTXTRPR-4649" will be 10 days. I am racking my brain on how to do this :(
This is all I could come up with so far:
While i < UBound(sTimeStamp)
If StrComp(Trim(Format(Now(), "MM-DD")), Trim(Split(sTimeStamp(9), ";")(1))) = 0 And StrComp(Trim(Worksheets("KPIs").Range("AN" & iCounter)), Trim(Split(sTimeStamp(1), ";")(0))) Then
End If
i = i + 1
Wend
Link to file
Sample File
The next code will return occurrences for each string in 'Task' range matching the date from its corresponding 'sTimeStamp Array' string with the one from the 'Date Range Array'. Each occurrence will be add to the next column of 'Task' string column:
Private Sub findOccurrences()
Dim sTask As Worksheet, sStamp As Worksheet, sDate As Worksheet
Dim arrTask As Variant, arrStamp As Variant, arrDate As Variant
Dim i As Long, j As Long, arrS As Variant, El As Variant, dtRef As Date
Set sTask = ThisWorkbook.Sheets("Task")
Set sStamp = ThisWorkbook.Sheets("sTimeStamp Array")
Set sDate = ThisWorkbook.Sheets("Date Range Array")
arrTask = sTask.Range("A2:A" & sTask.Range("A" & sTask.Rows.Count).End(xlUp).Row).Value
arrStamp = sStamp.Range("A2:A" & sStamp.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Value
arrDate = sDate.Range("A2:A" & sDate.Range("A" & sDate.Rows.Count).End(xlUp).Row).Value
'____________________________________________________________________________
sTask.Range("B2:K" & sTask.Range("A" & sTask.Rows.Count).End(xlUp).Row).Clear
Do While i < UBound(arrStamp)
i = i + 1
arrS = Split(arrStamp(i, 1), ";")
For j = 1 To UBound(arrTask)
If arrS(0) = arrTask(j, 1) Then
For Each El In arrDate
dtRef = DateValue(Format(El, "MM-DD"))
If dtRef = DateValue(Format(arrS(1), "MM-DD")) Then
Debug.Print arrS(0) & " (row number " & j + 1 & "), interval """ & _
El & """ exists."
sTask.Cells(j + 1, sTask.Cells(j + 1, _
sTask.Columns.Count).End(xlToLeft).Column).Offset(0, 1).Value = El
End If
Next
End If
Next j
Loop
End Sub
And the short variant working similar to your approach, finding the occurrences for Today date (if I correctly deduced what you intended to achieve), replace the looping part with this:
'______________________________________________________________________________
sStamp.Range("B2:B" & sStamp.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Clear
sTask.Range("A2:A" & sTask.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Interior.ColorIndex = -4142
While i < UBound(arrStamp)
i = i + 1
If StrComp(DateValue(Format(Date, "MM-DD")), DateValue(Split(arrStamp(i, 1), ";")(1))) = 0 And _
Not isMatchErr(CStr(Split(arrStamp(i, 1), ";")(1)), arrDate) Then
Debug.Print "OK for """ & Split(arrStamp(i, 1), ";")(0) & """ of row """ & i & """."
sStamp.Range("B" & i + 1).Value = "OK"
If Not isMatchErr(CStr(Split(arrStamp(i, 1), ";")(0)), arrTask) Then
rowOK = WorksheetFunction.Match(Split(arrStamp(i, 1), ";")(0), arrTask, 0) + 1
sTask.Range("A" & rowOK).Interior.ColorIndex = 3
End If
End If
Wend
And add the next function:
Function isMatchErr(strTime As String, arrDate As Variant) As Boolean
Dim k As Long
On Error Resume Next
k = WorksheetFunction.Match(strTime, arrDate, 0)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0: isMatchErr = True
End If
On Error GoTo 0
End Function
Besides the message in Immediate Window, an "OK" will be put on column B:B for all occurrences (in 'sTimeStamp Array' sheet) and background of the matching cell (in 'Task' sheet will be colored in red... In order to do that, I added a new record and modified an existing cell, for "Today" ("01-12"). Please do the same in order to obtain at least two results in column B:B.
Please confirm that this is what you wanted. If not, please better clarify the need...
I have the following code which crashes excel when run:
Option Explicit
Private Type Calculations
x As Double
x2 As Double
x3 As Double
x4 As Double
x5 As Double
h1 As Double
v1 As Double
a1 As Double
p1 As Double
h2 As Double
v2 As Double
a2 As Double
p2 As Double
h3 As Double
v3 As Double
a3 As Double
p3 As Double
h4 As Double
v4 As Double
a4 As Double
p4 As Double
h5 As Double
v5 As Double
a5 As Double
p5 As Double
End Type
Private Type Points
Point() As Calculations
End Type
Private Type Sections
Section() As Points
End Type
Function DynamicRedim()
Dim aSections As Sections
Dim aCalculations As Calculations
Dim aPoints() As Points
Dim i As Integer
Dim aSectionsDimension As Integer
Dim aPointsDimension As Integer
Dim aSectionsCount As Integer
Dim aPointsCount As Integer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
aSectionsDimension = 1
aPointsDimension = 5
ReDim Preserve aSections.Section(aSectionsDimension)
aPoints = aSections.Section()
ReDim Preserve aPoints(aPointsDimension)
For i = LBound(aSections.Section) To UBound(aSections.Section)
aSections.Section(i).Point = aPoints
Next
For aSectionsCount = LBound(aSections.Section) To UBound(aSections.Section) '<< believe crash occurs when aSectionsCount = UBound(aSections.Section)?????
For aPointsCount = LBound(aSections.Section(aSectionsCount).Point) To UBound(aSections.Section(aSectionsCount).Point)
aSections.Section(aSectionsCount).Point(aPointsCount).x = 0
aSections.Section(aSectionsCount).Point(aPointsCount).x2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).x3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).x4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).x5 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h1 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v1 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a1 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p1 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h5 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v5 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a5 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p5 = 0
Next
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Function
I added the nested for loops towards the end of the function to zero all the elements in the type. Before I added this step, I noticed the elements towards the end (ie v4,a4,p4,h4,v5,a5,p5,h5) somehow ended up with some really strange values - random numbers to power e-211.
Clearly I did not set these values but equally I don't want them either!!
This aside, the code should not crash excel either...I'm pretty certain that this occurs then the outer for loop reaches UBound(aSections.Section).
I cannot see any reason why this would do this. I've tried two separate computers to eliminate any computer related issues and it looks to be code related.
Can anyone suggest a fix for this?
Point and Points are both Excel Classes. It is always a bad idea to use the name of an Excel data type as the name of one of your variables. However, I do not believe that is the cause of the crash.
DynamicRedim does not return a value so it is a Sub not a Function. This is not important since you are not trying to return a value.
I believe the first problem is:
aPoints = aSections.Section()
Both aPoints and aSections.Section() are arrays of Points but they are defined in different ways. I suspect the alignment is slightly different and memory is being corrupted.
I believe the same sort of memory corruption occurs with:
For i = LBound(aSections.Section) To UBound(aSections.Section)
aSections.Section(i).Point = aPoints
Next
When I single step through your code, Excel crashes halfway down the first loop. It is possible to obtain the address of an Excel variable so we could perform a detailed investigation and prove the problem is corrupted memory but I do not think it would be worth the time.
Your problem is that you are trying to ReDim an array by copying a predefined array to it. I have copied arrays successfully but with the source and destination arrays having an identical definition. You cannot ReDim an array of arrays in the conventional way but you can ReDim aSections.Section(i).Point.
I have rewritten your code so it works. I have included an explanation for each of my changes. Come back with questions if those explanations are not adequate.
Option Explicit
Private Type Calculations
x As Double
x2 As Double
x3 As Double
x4 As Double
x5 As Double
h1 As Double
v1 As Double
a1 As Double
p1 As Double
h2 As Double
v2 As Double
a2 As Double
p2 As Double
h3 As Double
v3 As Double
a3 As Double
p3 As Double
h4 As Double
v4 As Double
a4 As Double
p4 As Double
h5 As Double
v5 As Double
a5 As Double
p5 As Double
End Type
' Every use of "Point" replaced by "Pnt" to avoid any conflict
' with Excel classes Point and Points
Private Type Pnts
Pnt() As Calculations
End Type
Private Type Sections
Section() As Pnts
End Type
Function DynamicRedim2()
Dim aSections As Sections
'Dim aCalculations As Calculations ' Not used by this code
'Dim aPoints() As Points ' Not used by this code
Dim i As Integer
Dim aSectionsDimension As Integer
Dim aPntsDimension As Integer
Dim aSectionsCount As Integer
Dim aPntsCount As Integer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
aSectionsDimension = 1
aPntsDimension = 5
' Removed Preserve because nothing to preserve
ReDim aSections.Section(aSectionsDimension)
' Use ReDim to size array rather than copying array of correct size
' Note: if "aSections.Section(i)" was an array, you cannot ReDim
' in this way because the syntax is invalid. You must pass
' "aSections.Section(i)" to a subroutine which can ReDim it. If this
' in not clear, I will construct an example to show what I mean.
For i = LBound(aSections.Section) To UBound(aSections.Section)
ReDim aSections.Section(i).Pnt(aPntsDimension)
Next
' Display aSections to show already initialised to zeros. VBA initialises
' all variables to a default value.
Call DsplSection(aSections)
For aSectionsCount = LBound(aSections.Section) To UBound(aSections.Section)
For aPntsCount = LBound(aSections.Section(aSectionsCount).Pnt) To _
UBound(aSections.Section(aSectionsCount).Pnt)
' I have changed the zeros to non-zero values to prove the code is
' changing all the elements.
' "1" is stored as an Integer and will have to be converted to a Double
' for each statement for each loop. "1#" tells the compiler to store 1
' as a Double.
aSections.Section(aSectionsCount).Pnt(aPntsCount).x = 1#
aSections.Section(aSectionsCount).Pnt(aPntsCount).x2 = 2#
aSections.Section(aSectionsCount).Pnt(aPntsCount).x3 = 3#
aSections.Section(aSectionsCount).Pnt(aPntsCount).x4 = 4#
aSections.Section(aSectionsCount).Pnt(aPntsCount).x5 = 5#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h1 = 6#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v1 = 7#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a1 = 8#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p1 = 9#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h2 = 10#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v2 = 11#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a2 = 12#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p2 = 13#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h3 = 14#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v3 = 15#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a3 = 16#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p3 = 17#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h4 = 18#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v4 = 19#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a4 = 20#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p4 = 21#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h5 = 22#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v5 = 23#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a5 = 24#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p5 = 25#
Next
Next
' Display new values
Call DsplSection(aSections)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Function
Sub DsplSection(ByRef SectionCrnt As Sections)
' For VBA, "Integer" specifies a 16-bit integer while "Long" defines a
' 32-bit integer. Integer variable are supposed to take longer to process
' than Long variable on 32-bit and 64-bit computers. VBA routines are
' difficult to time because of all the background processing that can occur
' at any time. My experiments have failed to detect any difference between
' Integer and Long variables. However, no harm in having the bigger variable.
Dim InxS As Long
Dim InxP As Long
For InxS = LBound(SectionCrnt.Section) To UBound(SectionCrnt.Section)
For InxP = LBound(SectionCrnt.Section(InxS).Pnt) To _
UBound(SectionCrnt.Section(InxS).Pnt)
Debug.Print InxS & " " & InxP & ": ";
' Note how much typing you save using a With statement
With SectionCrnt.Section(InxS).Pnt(InxP)
Debug.Print .x & " " & .x2 & " " & .x3 & " " & .x4 & " " & .x5 & " " & _
.h1 & " " & .v1 & " " & .a1 & " " & .p1 & " " & .h2 & " " & _
.v2 & " " & .a2 & " " & .p2 & " " & .h3 & " " & .v3 & " " & _
.a3 & " " & .p3 & " " & .h4 & " " & .v4 & " " & .a4 & " " & _
.p4 & " " & .h5 & " " & .v5 & " " & .a5 & " " & .p5
End With
Next
Next
End Sub
I have sales report from e-shop and need to calculate cost of goods for each order line. Order line can look like one of these:
2x Lavazza Crema e Aroma 1kg - 1x Lavazza Dolce Caffe Crema 1kg
1x Lavazza Vending Aroma Top 1kg - 1x Arcaffe Roma 1Kg - 1x Kimbo - 100% Arabica Top Flavour
So, what I need Excel to do is to take each product, find its cost with vlookup function from another sheet and then multiply it with amount ordered. The issue is that nr of products ordered can vary from 1 to 10+.
I tried to calculate it with VBA, but the code is not working (I didn´t use multiplying at the moment, I know)
Maybe it is possible to solve this problem with excel formulas?
Function GoodsCost(str, Optional strDelim As String = " ")
larray = Split(str, strDelim)
Set lookup_range = Worksheets("Products").Range("B:E")
For i = LBound(larray) To UBound(larray)
skuarray = Split(larray(i), "x ")
skucost = Application.WorksheetFunction.VLookup(UBound(skuarray), lookup_range, 4, False)
cost = cost + skucost
Next i
GoodsCost = cost
End Function
Well, it seems like now the problem is solved. Of course, it works only if make an assumption that dashes(-) are not present in product descriptions. But it can be set up in product list. The other opportunity is to use another delimeter (for example "/"). We can use Ctrl+F to find all combinations like "x -" and replace them with "x /")
Function GoodsCost(str)
Dim answer As Double
Set Products = Worksheets("Products").Range("B:E")
larray = Split(str, " - ")
For i = LBound(larray) To UBound(larray)
sku = Split(larray(i), "x ")
Price = Application.WorksheetFunction.VLookup(sku(1), Products, 4, False) * sku(0)
answer = answer + Price
Next i
GoodsCost = answer
End Function
Below you find a UDF (User Defined Function) which you can use in your worksheet. After installing it in a standard code module (VBE names these like "Module1") you can call it from the worksheet like =CostOfGoods($A2) where A2 is the cell containing and order line as you have described.
Option Explicit
Function CostOfGoods(Cell As Range) As Single
' 15 Jan 2018
Const Delim As String = " - "
Dim Fun As Single ' function return value
Dim Sale As Variant
Dim Sp() As String
Dim i As Long
Dim PriceList As Range
Dim Qty As Single, Price As Single
Dim n As Integer
Sale = Trim(Cell.Value)
If Len(Sale) Then
Sp = Split(Sale, Delim)
Do While i <= UBound(Sp)
If InStr(Sp(i), "x ") = 0 Then
If Not ConcatSale(Sp, i, Delim) Then Exit Do
End If
i = i + 1
Loop
With Worksheets("Products")
i = .Cells(.Rows.Count, "B").End(xlUp).Row
' price list starts in row 2 (change as required)
Set PriceList = Range(.Cells(2, "B"), .Cells(i, "E"))
End With
For i = 0 To UBound(Sp)
Qty = Val(Sp(i))
n = InStr(Sp(i), " ")
Sp(i) = Trim(Mid(Sp(i), n))
On Error Resume Next
Price = Application.VLookup(Sp(i), PriceList, 4, False)
If Err Then
MsgBox "I couldn't find the price for" & vbCr & _
Sp(i) & "." & vbCr & _
"The total cost calculated excludes this item.", _
vbInformation, "Price not found"
Price = 0
End If
Fun = Fun + (Qty * Price)
Next i
End If
CostOfGoods = Fun
End Function
Private Function ConcatSale(Sale() As String, _
i As Long, _
Delim As String) As Boolean
' 15 Jan 2018
Dim Fun As Boolean ' function return value
Dim x As Long, f As Long
x = UBound(Sale)
If (i > 0) And (i <= x) Then
i = i - 1
Sale(i) = Sale(i) & Delim & Sale(i + 1)
For f = i + 1 To x - 1
Sale(f) = Sale(f + 1)
Next f
Fun = True
End If
If Fun Then ReDim Preserve Sale(x - 1)
ConcatSale = Fun
End Function
I have tested this and it works with dashes in product description:
Function GoodsCost(str, Optional strDelim As String = " ")
larray = Split(str, " ")
'split the cell contents by space
Set lookup_range = Worksheets("Products").Range("B:E")
'set lookup range
For i = LBound(larray) To UBound(larray) 'loop through array
nextproduct:
LPosition = InStr(larray(i), "x") 'find multiplier "x" in string
If LPosition = Len(larray(i)) Then 'if the last character is x
If Product <> "" Then GoTo lookitup 'lookup product
Quantity = larray(i) 'get quantity
Else
Product = Product & " " & larray(i) 'concatenate array until we get a full product description to lookup with
End If
Next i
lookitup:
If Right(Product, 2) = " -" Then Product = Left(Product, Len(Product) - 2)
If Left(Product, 1) = " " Then Product = Right(Product, Len(Product) - 1)
'above trim the Product description to remove unwanted spaces or dashes
cost = Application.WorksheetFunction.VLookup(Product, lookup_range, 4, False)
Quantity = Replace(Quantity, "x", "")
GoodsCost = cost * Quantity
MsgBox Product & " # Cost: " & GoodsCost
Product = ""
If i < UBound(larray) Then GoTo nextproduct
End Function
I'd use Regular Expressions to solve this. First it finds in the string were the 'delimiters' are by replacing the - with ; detecting only - that are next to a number followed by an x (i.e. a multiplier so ignoring - in product names). It then splits each of these results into a quantity and the product (again using RegEx). It then finds the product in your data and returns the cost of goods. If there is an error, or the product isn't in your data it returns a #Value error to show that there is an issue.
Public Function GoodsCost(str As String) As Double
Dim lookup_range As Range, ProductMatch As Range
Dim v, Match
Dim qty As Long
Dim prod As String
Dim tmp() As String
On Error GoTo err
Set lookup_range = Worksheets("Products").Range("B:E")
With CreateObject("vbscript.regexp")
.Global = True
.ignorecase = True
.pattern = "(\s\-\s)(?=[0-9]+x)"
If .test(str) Then
tmp = Split(.Replace(str, ";"), ";")
Else
ReDim tmp(0)
tmp(0) = str
End If
.pattern = "(?:([0-9]+)x\s(.+))"
For Each v In tmp
If .test(v) Then
Set Match = .Execute(v)
qty = Match.Item(0).submatches.Item(0)
prod = Trim(Match.Item(0).submatches.Item(1))
Set ProductMatch = lookup_range.Columns(1).Find(prod)
If Not ProductMatch Is Nothing Then
GoodsCost = GoodsCost + (qty * ProductMatch.Offset(0, 3))
Else
GoodsCost = CVErr(xlErrValue)
End If
End If
Next v
End With
Exit Function
err:
GoodsCost = CVErr(xlErrValue)
End Function
How can I find sequential numbers in a cell, and replace them with a range?
For example:
change:
1，3，5，15，16，17，25，28，29，31...
to:
1,3,5,15-17,25,28-29,31...
The numbers are already sorted, i.e. in increasing order.
Thanks.
An interesting question that I wanted to look at do without looping through a sequence (which would need sorting first) checking for sequential builds
This function
forces the string to a range address
uses Union to group consecutive rows together
manipulates the string to remove the column identifier
loop wasn't necessary, shorter version!
Function NumOut(strIn As String) As String
Dim rng1 As Range
Set rng1 = Range("A" & Join(Split(Application.Trim([a1]), ", "), ",A"))
'force the range into areas rather than cells
Set rng1 = Union(rng1, rng1)
NumOut = Replace(Replace(Replace(rng1.Address, "$A$", vbNullstring), ": ", "-"), ",", ", ")
End Function
Thought I'd try an all-formulae solution using Microsoft365's LET() as a way to capture variables.
The below solution only counts 3+ consecutive numbers as ranges of numbers, not two.
Formula in B1:
=LET(X,FILTERXML("<t><s>"&SUBSTITUTE(A1,",","</s><s>")&"</s></t>","//s"),Y,TRANSPOSE(FILTERXML("<t><s>"&SUBSTITUTE(A1,",","</s><s>")&"</s></t>","//s[preceding::*[1]+1=.][following::*[1]-1=.]")),SUBSTITUTE(TEXTJOIN(",",,FILTERXML("<t><s>"&TEXTJOIN("</s><s>",,IF(MMULT(--(X=Y),SEQUENCE(COUNTA(Y),,,0)),"-",X))&"</s></t>","//s[.*0=0 or (.='-' and preceding::*[1]*0=0)]")),",-,","-"))
While the given range/area based answer is interesting, it suffers from a couple of flaws:
It is limited to an input string of 255 characters
It is relatively slow
Here's a basic array loop based method. It can handle long strings. In my testing it runs in about 1/3 the time. It also has the bonus of not requiring the input to be sorted
Function NumOut2(strIn As String) As String
Dim arrIn() As String
Dim arrBuckets() As Long
Dim i As Long
Dim InRange As Boolean
Dim mn As Long, mx As Long
arrIn = Split(strIn, ", ")
mn = arrIn(0)
mx = arrIn(0)
For i = 1 To UBound(arrIn)
If arrIn(i) < mn Then
mn = arrIn(i)
ElseIf arrIn(i) > mx Then
mx = arrIn(i)
End If
Next
ReDim arrBuckets(mn To mx)
For i = 0 To UBound(arrIn)
arrBuckets(arrIn(i)) = arrIn(i)
Next
NumOut2 = LBound(arrBuckets)
InRange = False
For i = LBound(arrBuckets) + 1 To UBound(arrBuckets)
If arrBuckets(i) > 0 Then
If arrBuckets(i) = arrBuckets(i - 1) + 1 Then
If InRange Then
Else
InRange = True
NumOut2 = NumOut2 & "-"
End If
Else
If InRange Then
NumOut2 = NumOut2 & arrBuckets(i - 1) & ", " & arrBuckets(i)
Else
NumOut2 = NumOut2 & ", " & arrBuckets(i)
End If
End If
Else
If InRange Then
NumOut2 = NumOut2 & arrBuckets(i - 1)
End If
InRange = False
End If
Next
End Function