VBA Split array - vba

I have the following code:
Sub UpdateBlock()
'Define empty variables for each attribute
Dim ent As AcadEntity
Dim oBkRef As AcadBlockReference
Dim Insertpoints As Variant
Dim A As Double
Dim tag As String
Dim material As String
Dim actualLength As String
Dim cutOff As Double
Dim cutLengths As Double
Dim totalLengths As Double
Dim weight As Double
Dim purchaseLength As Double
Dim decimalLength As Double
Dim lengthWeight As Double
Dim totalLengthWeight As Double
Dim cutLengthWeight As Double
Dim cutWeight As Double
Dim order As Double
Dim feet As Double
Dim inches As Double
Dim fraction As Double
Dim fracVal As Variant
'First we go over every object in the modelspace
For Each ent In ThisDrawing.ModelSpace
'Check if the object is a block
If ent.ObjectName = "AcDbBlockReference" Then
Set oBkRef = ent
'If the object is a block then check if its the block we are looking for
If oBkRef.EffectiveName = "AUTOTAG-MATERIAL" Then
A = A + 1
'Get Current Attributes
attlist = oBkRef.GetAttributes
For i = LBound(attlist) To UBound(attlist)
Select Case attlist(i).TagString
Case "ACTUAL-LENGTH"
actualLength = attlist(i).TextString
Case "PURCHASE-LENGTH"
purchaseLength = attlist(i).TextString
Case "CUT-OFF"
cutOff = Frac2Num(attlist(i).TextString)
Case "DECIMAL-LENGTH"
feet = Split(actualLength)(0)
inches = Split(actualLength)(1)
fracVal = Split(actualLength)(2)
If Not IsNull(Split(actualLength)(2)) Then
fraction = Frac2Num(fracVal)
Else
fraction = 0
End If
decimalLength = Round((((feet * 12) + (inches + fraction)) / 12) - cutOff, 2)
attlist(i).TextString = decimalLength
Case "WEIGHT"
weight = attlist(i).TextString
Case "CUT-WEIGHT"
cutWeight = weight * decimalLength
attlist(i).TextString = cutWeight
Case "LENGTH-WEIGHT"
lengthWeight = weight * purchaseLength
attlist(i).TextString = lengthWeight
Case "TOTAL-LENGTHS"
totalLengths = attlist(i).TextString
Case "CUT-LENGTHS"
cutLength = attlist(i).TextString
Case "TOTAL-LENGTH-WEIGHT"
totalLengthWeight = lengthWeight * totalLengths
attlist(i).TextString = totalLengthWeight
Case "CUT-LENGTH-WEIGHT"
totalCutWeight = lengthWeight * cutLength
attlist(i).TextString = totalCutWeight
End Select
Next
End If
End If
Next ent
End Sub
Function Frac2Num(ByVal X As String) As Double
Dim P As Integer, N As Double, Num As Double, Den As Double
X = Trim$(X)
P = InStr(X, "/")
If P = 0 Then
N = Val(X)
Else
Den = Val(Mid$(X, P + 1))
If Den = 0 Then Error 11 ' Divide by zero
X = Trim$(Left$(X, P - 1))
P = InStr(X, " ")
If P = 0 Then
Num = Val(X)
Else
Num = Val(Mid$(X, P + 1))
N = Val(Left$(X, P - 1))
End If
End If
If Den <> 0 Then
N = N + Num / Den
End If
Frac2Num = N
End Function
The variable fraction / fracVal comes from a tag in AutoCAD that is a length, that will always be at least "0 0", but may be "0 0 0" it is a length in feet, inches, and fractional inches. So some possible values could be "8 5", "16 11 11/16", "0 5 3/8" etc.
What I need is a check for when the fraction is not there.
Any suggestions?

I would split the string on the space and see if the ubound of the resulting array is 2. So something like this
If Ubound(Split(thisString, " ")) = 2 then
'fractional part is present
End If

Another option is the Like Operator:
If thisString Like "#* #* #*/#*" Then
# matches any single digit (0–9) and * matches zero or more characters.
but since you split the string anyway, I would store the result of the split in a variable and check the number of items in it with UBound as shown in the other answer.

Related

Graphics drawline scaling vb.net

I'm trying to develop a program that has been made by another person.
What I develop is just for showing the measurement point like the picture below.
There are min and max data that appear in the form and it's showing from the smallest to the largest value and every time the mouse moves from left to right, the measuring point value will adjust to the graph value that has been determined as above.
The problem is data accuracy at the measuring point does not match with the value that has been determined, this is because the graphic is out of frame.
Here is the code for showing graphics;
Private Sub UpdateDiaGraph()
Call Me.ClearGraph(Me.gDia, Me.PicDiaGraph)
Call Me.InitializeGraph(Me.gDia, Me.PicDiaGraph, Me.recDia)
If Me.dsData.Tables("Dia").Rows.Count = 0 Then
Exit Sub
End If
Dim drs() As DataRow = Me.dsData.Tables("Dia").Select("", "[PathNo],[EquipmentNo],[Point]")
Dim pathNo As Integer = 0
Dim equipmentNo As Integer = 0
Dim diaCount As Integer = 0
Dim maxPoint As Integer = 0
Dim longestDiaCount As Integer = 0
Dim upper As New List(Of Decimal)
Dim lower As New List(Of Decimal)
For Each dr As DataRow In drs
If pathNo <> dr("PathNo") Or equipmentNo <> dr("EquipmentNo") Then
pathNo = dr("PathNo")
equipmentNo = dr("EquipmentNo")
'Count the graphics
diaCount += 1
' Get standard width
upper.Add(dr("Upper"))
lower.Add(dr("Lower"))
End If
' Get the max number of graph points and the number of graphs at that time
If maxPoint < dr("Point") Then
maxPoint = dr("Point")
longestDiaCount = diaCount
End If
Next
Dim x1, x2 As Decimal
Dim y1, y2 As Decimal
' Get the width to draw the reference line
Dim oneHeight As Decimal = Me.recDia.Height / (diaCount + 1)
'Initialize the graph
For i As Integer = 1 To diaCount
x1 = Me.recDia.Left + 1
x2 = Me.recDia.Left + Me.recDia.Width - 1
y1 = Me.recDia.Top + oneHeight * i
' Tolerance range
'※0.01mm/1 Point
Me.gDia.FillRectangle(New SolidBrush(Me.toleranceRecColor) _
, x1 _
, y1 - upper(diaCount - i) * 100 _
, Me.recDia.Width - 1 _
, (upper(diaCount - i) - lower(diaCount - i)) * 100)
' reference line
Me.gDia.DrawLine(New Pen(Me.centerLineColor), x1, y1, x2, y1)
Next
' Determine the drawing magnification of the X-axis so that the max number of points can be displayed
Dim xMag As Decimal = Me.recDia.Width / maxPoint
'Draw a graph
Dim counter As Integer = 0
Dim centerLineY As Decimal
Dim center As Decimal = 0
Dim p As Integer = -1
pathNo = 0 : equipmentNo = 0
For Each dr As DataRow In drs
' Get reference line and reference value
If pathNo <> dr("PathNo") Or equipmentNo <> dr("EquipmentNo") Then
pathNo = dr("PathNo")
equipmentNo = dr("EquipmentNo")
counter += 1
centerLineY = Me.recDia.Top + oneHeight * (diaCount - (counter - 1))
center = dr("Center")
'Draw chart title and reference value
Dim num As New Common.Numeric
Dim numFormat As String = num.GetNumericFormat(1, 2)
Dim s As String = dr("MeasuringTarget").ToString & ControlChars.CrLf
Dim sSize As Size = TextRenderer.MeasureText(Me.gDia, s, Me.Font)
Me.gDia.DrawString(s, Me.Font, Brushes.White, Me.recDia.Left - sSize.Width - 2, centerLineY - sSize.Height / 2)
s = ControlChars.CrLf & Format(center, numFormat)
sSize = TextRenderer.MeasureText(Me.gDia, s, Me.Font)
Me.gDia.DrawString(s, Me.Font, Brushes.White, Me.recDia.Left - sSize.Width - 2, centerLineY - sSize.Height / 2)
x1 = 0 : x2 = 0 : y1 = 0 : y2 = 0 : p = -1
End If
p += 1
'Change the drawing direction and starting point of the graph depending on the number of direction changes
If Me.extRevCnt.Item(pathNo) Mod 2 = 0 Then
x2 = Me.recDia.Left + p * xMag
Else
x2 = Me.recDia.Left + Me.recDia.Width - p * xMag
End If
y2 = centerLineY - (dr("Data") - center) * 100
If p <> 0 Then
'graph drawing
If Me.recDia.Top < y2 And y2 < Me.recDia.Top + Me.recDia.Height Then
' Change the drawing color of the graph for each outer diameter
If counter < Me.diaGraphColor.Count Then
Me.gDia.DrawLine(New Pen(Me.diaGraphColor(counter)), x1, y1, x2, y2)
Else
Me.gDia.DrawLine(New Pen(Me.graphColor), x1, y1, x2, y2)
End If
End If
' out of tolerance
If dr("DataFlag") = Common.Constant.DataFlag.NG Then
Me.gDia.DrawLine(New Pen(Me.ngColor), x1, centerLineY, x2, centerLineY)
End If
'Draw a scale every 10m * However, only when drawing the longest graph
'Drawn for the first graph (normal mandrel diameter)
If counter = 1 Then
If p Mod 100 = 0 Then
Me.gDia.DrawLine(Pens.White, x2, Me.recDia.Top + Me.recDia.Height, x2, Me.recDia.Top + Me.recDia.Height - 3)
Dim s As String = (p \ 10).ToString & "m"
Dim sSize As Size = TextRenderer.MeasureText(Me.gDia, s, Me.Font)
Me.gDia.DrawString(s, Me.Font, Brushes.White, x2 - sSize.Width / 2, Me.recDia.Top + Me.recDia.Height + 2)
End If
End If
Else
' determine the corners of a polygon
Dim points As Point() = {New Point(x2, centerLineY - 10), New Point(x2 - 10, centerLineY - 40), New Point(x2 + 10, centerLineY - 40)}
Me.gDia.FillPolygon(Brushes.Blue, points, System.Drawing.Drawing2D.FillMode.Alternate)
' Display the division number in the circle above
Dim s As String = dr("DivNo").ToString
Dim sSize As Size = TextRenderer.MeasureText(Me.gDia, s, Me.Font)
Me.gDia.DrawString(s, New Font(Me.Font, FontStyle.Regular), Brushes.White, x2 - sSize.Width / 2 + 2, centerLineY - 35)
End If
x1 = x2
y1 = y2
Next
Type.Variable.divideTargetDia = Me.DGVDataDia.SelectedRows.Item(0).Index
Call Me.DrawingGraphDia(Me.DGVDataDia.SelectedRows.Item(0).Index)
Me.PicDiaGraph.Refresh()
End Sub
Here is the code for showing data pointer
Private Sub PicDiaGraph_Paint(ByVal gDia As Graphics)
If IsNothing(tblDataDia) = True Then Exit Sub
If tblDataDia.Rows.Count = 0 Then Exit Sub
If IsNothing(tblEquipmentNoDia) = True Then Exit Sub
If tblEquipmentNoDia.Rows.Count = 0 Then Exit Sub
' Allocate the drawing range according to the number of device numbers
Dim allHeight As Integer = Me.PicDiaGraph.Size.Height
'Drawing range per device number
Dim heightPerEN As Integer = allHeight / (tblEquipmentNoDia.Rows.Count + 1)
' Device number count
Dim count As Integer = 0
' Draw a graph for each device number
For Each rEN As DataRow In tblEquipmentNoDia.Rows
Dim eNo As Integer = rEN("EquipmentNo")
Dim tblSource As DataTable = tblDataDia.Clone
For Each r As DataRow In tblDataDia.Select("EquipmentNo = '" & eNo & "'", "Point ASC")
tblSource.ImportRow(r)
Next
' Acquisition of standard value
Dim tblStandard As New DataTable
If Me.Today = False Then
Dim SQL As String = ""
SQL &= "SELECT Standard.Center "
SQL &= "FROM Standard "
SQL &= "WHERE Standard.EquipmentNo = " & eNo & " And Standard.MfgID = '" & barcodeNo.Trim & "' "
SQL &= "GROUP BY Standard.Center;"
daDia = New OleDb.OleDbDataAdapter(SQL, cnMdbDia)
daDia.Fill(tblStandard)
Else
'
End If
Dim center As Single = Format(tblStandard.Rows(0)("center"), "0.00")
' Drawing start position (height)
Dim shift As Integer = heightPerEN * count
'get width of data
Dim margin As Integer = 0
_xMaxDia = tblSource.Select("Point = MAX(Point)")(0)("Point")
_xMinDia = tblSource.Select("Point = MIN(Point)")(0)("Point")
Dim yMax As Single = tblSource.Select("Data = MAX(Data)")(0)("Data")
Dim yMin As Single = tblSource.Select("Data = MIN(Data)")(0)("Data")
'Width on X-axis data
Dim xRange As Integer = _xMaxDia - _xMinDia
'Width on Y-axis data
Dim yRange As Single = yMax - yMin
'Get size of control
Dim height As Integer = heightPerEN - (margin * 2)
Dim width As Integer = Me.PicDiaGraph.Size.Width - 21
' Nominal length per unit
_xUnitDia = width / xRange
Dim yUnit As Single = 200
'graph drawing
For i As Integer = 0 To tblSource.Rows.Count - 2
Dim x1 As Decimal = Me.recDia.Left + 1
' starting point data
Dim row1 As DataRow = tblSource.Rows(i)
Dim point1 As Integer = row1("Point")
Dim data1 As Single = row1("Data")
' end point data
Dim row2 As DataRow = tblSource.Rows(i + 1)
Dim point2 As Integer = row2("Point")
Dim data2 As Single = row2("Data")
If point2 < point1 Then MessageBox.Show("X")
Me.gDia.DrawLine(Pens.White, _
CInt((point1 - _xMinDia) * _xUnitDia), _
height - (data1 - center) * yUnit + margin + shift, _
CInt(point2 - _xMinDia) * _xUnitDia, _
height - (data2 - center) * yUnit + margin + shift)
Next
count += 1
Next
End Sub
The problem might appear in this code

Change subitem backcolor of a listview next item

I have a listview filled with SRT subtitle. I'am trying to change listview color based on subtitle errors. Everything is working fine, but color won't change when subtitles is overlapping. I take end-time of one subtitle and start-time of next subtitle. Based on difference, it decide is there overlapping or not. Calculations are OK but backcolor and forecolor won't change. It does change backcolor for current item but I need to change backcolor for next listview item.
'EXAMPLE #######################################
For i as integer = 0 to listview1.items.count -1
ListView1.Items(i).UseItemStyleForSubItems = False
'this is working #######
ListView1.Items.Item(i).SubItems(1).BackColor = ColorTranslator.FromHtml("#F0A6A7")
'but this is NOT working ( THIS IS WHAT I NEED) ####################
ListView1.Items.Item(i).SubItems(i + 1).BackColor = ColorTranslator.FromHtml("#F0A6A7")
Next i
'########################################################
Public Function Color_Errors(ByVal SubtitleListView As ListView)
For i = 0 To SubtitleListView.Items.Count - 2
SubtitleListView.Items(i).UseItemStyleForSubItems = False
SubtitleListView.Items(i + 1).UseItemStyleForSubItems = False
SubtitleListView.Items.Item(i).SubItems(1).ResetStyle()
SubtitleListView.Items.Item(i).SubItems(2).ResetStyle()
SubtitleListView.Items.Item(i).SubItems(3).ResetStyle()
SubtitleListView.Items.Item(i).SubItems(4).ResetStyle()
SubtitleListView.Items.Item(i).SubItems(5).ResetStyle()
Dim Text As String = SubtitleListView.Items.Item(i + 1).SubItems(5).Text
Dim TextLength As Integer = Get_Longest_Line_Length(Text)
Dim NumberOfLines As Integer = Split(Text, "|").Length
Dim Duration As Double = Convert_Time_to_Milliseconds(SubtitleListView.Items.Item(i).SubItems(4).Text)
Dim Pause As Double = Convert_Time_to_Milliseconds(SubtitleListView.Items.Item(i).SubItems(1).Text)
Dim _Start As Double = Convert_Time_to_Milliseconds(SubtitleListView.Items.Item(i).SubItems(2).Text)
Dim _End As Double = Convert_Time_to_Milliseconds(SubtitleListView.Items.Item(i).SubItems(3).Text)
Dim _NextStart As Double
If i < (SubtitleListView.Items.Count - 1) Then
_NextStart = Convert_TimeSpan_to_Milliseconds(SubtitleListView.Items.Item(i + 1).SubItems(2).Text)
End If
'TOO LONG LINES
If TextLength > MaxLength Then
SubtitleListView.Items.Item(i).SubItems(5).BackColor = ColorTranslator.FromHtml("#F0A6A7")
SubtitleListView.Items.Item(i).SubItems(5).ForeColor = Color.Black
End If
'TOO LONG DURATION
If Duration > 6000 Then
SubtitleListView.Items.Item(i).SubItems(4).BackColor = ColorTranslator.FromHtml("#F5CBD9")
SubtitleListView.Items.Item(i).SubItems(4).ForeColor = ColorTranslator.FromHtml("#6F0021")
SubtitleListView.Items.Item(i).SubItems(3).BackColor = ColorTranslator.FromHtml("#F5CBD9")
SubtitleListView.Items.Item(i).SubItems(3).ForeColor = ColorTranslator.FromHtml("#6F0021")
'SHORTER THAN 2 SECONDS
ElseIf Duration < 2000 AndAlso Duration >= 700 Then
SubtitleListView.Items.Item(i).SubItems(4).BackColor = Color.Red
SubtitleListView.Items.Item(i).SubItems(4).ForeColor = Color.White
'TOO SHORT DURATION
ElseIf Duration < 700 Then
SubtitleListView.Items.Item(i).SubItems(3).BackColor = ColorTranslator.FromHtml("#FFF0E1")
SubtitleListView.Items.Item(i).SubItems(3).ForeColor = ColorTranslator.FromHtml("#A45200")
SubtitleListView.Items.Item(i).SubItems(4).BackColor = ColorTranslator.FromHtml("#FFF0E1")
SubtitleListView.Items.Item(i).SubItems(4).ForeColor = ColorTranslator.FromHtml("#A45200")
End If
''TOO SHORT PAUSE
If Pause < 200 Then
SubtitleListView.Items.Item(i).SubItems(1).BackColor = ColorTranslator.FromHtml("#ACC9E6")
SubtitleListView.Items.Item(i).SubItems(1).ForeColor = Color.Black
SubtitleListView.Items.Item(i).SubItems(2).BackColor = ColorTranslator.FromHtml("#ACC9E6")
SubtitleListView.Items.Item(i).SubItems(2).ForeColor = Color.Black
End If
If NumberOfLines > 2 Then
SubtitleListView.Items.Item(i).SubItems(5).ForeColor = ColorTranslator.FromHtml("#0000FF")
End If
'ERROR PART #################################################
If i < (SubtitleListView.Items.Count - 1) Then
If _End > _NextStart Then
SubtitleListView.Items.Item(i + 1).SubItems(1).BackColor = ColorTranslator.FromHtml("#BB0025")
SubtitleListView.Items.Item(i + 1).SubItems(1).ForeColor = Color.White
SubtitleListView.Items.Item(i).SubItems(2).BackColor = ColorTranslator.FromHtml("#BB0025")
SubtitleListView.Items.Item(i).SubItems(2).ForeColor = Color.White
End If
End If
'############################################################
Next i
Return Nothing
End Function
Public Function Convert_Time_to_Milliseconds(ByVal Time As String)
If Time.Contains(":") = True Then
Dim VremePrviDeo() As String = Split(Time, ":")
If VremePrviDeo.Length = 3 Then
Dim Sati As Integer = VremePrviDeo(0) * 60 * 60 * 1000
Dim Minuti As Integer = VremePrviDeo(1) * 60 * 1000
Dim VremeDrugiDeo() As String = Split(VremePrviDeo(2), ",")
Dim Sekunde As Integer = VremeDrugiDeo(0) * 1000
Dim Milisekunde As Integer = VremeDrugiDeo(1)
Dim Miliseconds As Double = Sati + Minuti + Sekunde + Milisekunde
Return Miliseconds.ToString
ElseIf VremePrviDeo.Length = 2 Then
Dim Minuti As Integer = VremePrviDeo(0) * 60 * 1000
Dim VremeDrugiDeo() As String = Split(VremePrviDeo(2), ",")
Dim Sekunde As Integer = VremeDrugiDeo(0) * 1000
Dim Milisekunde As Integer = VremeDrugiDeo(1)
Dim Miliseconds As Double = Minuti + Sekunde + Milisekunde
Return Miliseconds.ToString
End If
Else
Dim VremePrviDeo() As String = Split(Time, ",")
Dim Sekunde As Integer = VremePrviDeo(0) * 1000
Dim Milisekunde As Integer = VremePrviDeo(1)
Dim Miliseconds As Double = Sekunde + Milisekunde
Return Miliseconds.ToString
End If
Return Nothing
End Function
Public Function Get_Longest_Line_Length(ByVal Text As String)
Dim Duzina As Integer = 0
For Each line As String In Split(Text, "|")
If line.Length > Duzina Then
Duzina = line.Length
End If
Next
Return Duzina
End Function
Public Function Convert_TimeSpan_to_Milliseconds(ByVal Time As String)
'Try
Dim Parsed() As String = Parse_String_to_TimeSpan(Time)
Dim Sat As Double = TimeSpan.FromHours(Parsed(0)).TotalMilliseconds
Dim Minut As Double = TimeSpan.FromMinutes(Parsed(1)).TotalMilliseconds
Dim Sekunda As Double = TimeSpan.FromSeconds(Parsed(2)).TotalMilliseconds
Dim Milisekunda As Double = TimeSpan.FromMilliseconds(Parsed(3)).TotalMilliseconds
Dim TotalTime As Double = Sat + Minut + Sekunda + Milisekunda
Return TotalTime
'Catch ex As Exception
'End Try
'Return Nothing
End Function

Excel VBA: Variable as First Row of Selection?

I am creating a function in Excel VBA. I am trying to set a variable equal to the first cell in a selection on the worksheet. Basically the equivalent of something like
x = Worksheets("Data").Range("D2").Offset(i - 1, 0)
y = Worksheets("Data").Range("E2").Offset(i - 1, 0)
z = Worksheets("Data").Range("F2").Offset(i - 1, 0)
except I want "Range("D2")" E2 and F2 to instead refer to the first, second and third cell of whatever I've got highlighted on the sheet, rather than a preset cell.
The specific code I've got is:
Function VarunModel(Table As Range, Optional EndCondition As Integer = 0) As Variant
Dim iNumCols As Integer, iNumRows As Integer
Dim i As Integer
Dim SelectedRange As Range
Set SelectedRange = Selection
iNumCols = Table.Columns.Count
iNumRows = Table.Rows.Count
maturity = Worksheets("KMV-Merton").Range("B2").Value
For i = 1 To iNumRows
equity(i) = SelectedRange.Cells(1).Value
debt(i) = SelectedRange.Cells(2).Value
riskFree(i) = Selection.Cells(3).Value
Next i
Dim equityReturn As Variant: ReDim equityReturn(2 To iNumRows)
Dim sigmaEquity As Double
Dim asset() As Double: ReDim asset(1 To iNumRows)
Dim assetReturn As Variant: ReDim assetReturn(2 To iNumRows)
Dim sigmaAsset As Double, meanAsset As Double
Dim x(1 To 1) As Double, n As Integer, prec As Double, precFlag As Boolean, maxDev As Double
For i = 2 To iNumRows: equityReturn(i) = Log(equity(i) / equity(i - 1)): Next i
sigmaEquity = WorksheetFunction.StDev(equityReturn) * Sqr(260)
sigmaAsset = sigmaEquity * equity(iNumRows) / (equity(iNumRows) + debt(iNumRows))
NextItr: sigmaAssetLast = sigmaAsset
For iptr = 1 To iNumRows
x(1) = equity(iptr) + debt(iptr)
n = 1
prec = 0.00000001
Call NewtonRaphson(n, prec, x, precFlag, maxDev)
asset(iptr) = x(1)
Next iptr
For i = 2 To iNumRows: assetReturn(i) = Log(asset(i) / asset(i - 1)): Next i
sigmaAsset = WorksheetFunction.StDev(assetReturn) * Sqr(260)
meanAsset = WorksheetFunction.Average(assetReturn) * 260
If (Abs(sigmaAssetLast - sigmaAsset) > prec) Then GoTo NextItr
Dim disToDef As Double: disToDef = (Log(asset(iNumRows) / debt(iNumRows)) + (meanAsset - sigmaAsset ^ 2 / 2) * maturity) / (sigmaAsset * Sqr(maturity))
Dim defProb As Double: defProb = WorksheetFunction.NormSDist(-disToDef)
VarunModel = defProb
End Function
Thanks.
Try the below code
Dim SelectedRange As Range
Set SelectedRange = Selection
x = SelectedRange.Cells(1).Value
y = SelectedRange.Cells(2).Value
z = SelectedRange.Cells(3).Value
try this:
Dim Row as integer
Dim Col as Integer
Row = 2
Col = 4 'column "D"
x = Worksheets("Data").cells(row, col).Offset(i - 1, 0)
col = col + 1
y = Worksheets("Data").cells(row, col).Offset(i - 1, 0)
col = col + 1
z = Worksheets("Data").cells(row, col).Offset(i - 1, 0)
See the example below for using the selection on the excel, you can control the column you want by changing the column index. If you select only 1 cell, it will also work:
Sub Solution()
x = Selection.Cells(1, 0) 'By using the zero index on the column, it will get the left cell from the selected one.
y = Selection.Cells(2, 0)
Z = Selection.Cells(3, 0)
End Sub

Type mismatch error when generating random numbers

When I generate random numbers, I sometimes get (not always) the following error:
Run-time error '13': type mismatch.
on line Z = Sqr(time) * Application.NormSInv(Rnd()) (and the end of the second for loop).
Why do I get this error?
I think it has something to do with the fact that it contains Rnd().
Sub asiancall()
'defining variables
Dim spot As Double
Dim phi As Integer
Dim rd_cont As Double
Dim rf_cont As Double
Dim lambda As Double
Dim muY As Double
Dim sigmaY As Double
Dim vol As Double
Dim implied_vol As Double
Dim spotnext As Double
Dim time As Double
Dim sum As Double
Dim i As Long
Dim mean As Double
Dim payoff_mean As Double
Dim StDev As Double
Dim K As Double
Dim Egamma0 As Double
Dim mulTv As Double
Dim prod As Double
Dim U As Double
Dim Pois As Double
Dim Q As Double
Dim Z As Long
Dim gamma As Double
Dim payoff As Double
Dim payoff_sum As Double
Dim secondmoment As Double
Dim j As Long
Dim N As Long
Dim mu As Double
Dim sum1 As Double
'read input data
spot = Range("B3")
rd_cont = Range("C5")
rf_cont = Range("C4")
muY = Range("B17")
sigmaY = Range("B18")
lambda = Range("B16")
K = Range("F33")
implied_vol = Range("F35")
N = Range("F34")
vol = Range("B6")
'calculations
sum_BS = 0
payoff_BS = 0
mean_BS = 0
secondmoment_BS = 0
For j = 1 To N
spotnext = spot
spotnext_BS = spot
time = 0
sum1 = 0
time = 184 / (360 * 6)
For i = 1 To 6
' 'Merton uitvoeren
Egamma0 = Exp(muY + sigmaY * sigmaY * 0.5) - 1
mu = rd_cont - rf_cont
mulTv = (mu - lambda * Egamma0 - implied_vol * implied_vol * 0.5) * time
sum = 0
prod = 1
Do While sum <= time
U = Rnd()
Pois = -Log(U) / lambda
sum = sum + Pois
Q = Application.NormInv(Rnd(), muY, sigmaY)
gamma = Exp(Q) - 1
prod = prod * (1 + gamma)
Loop
prod = prod / (1 + gamma)
Z = Sqr(time) * Application.NormSInv(Rnd())
spotnext = spotnext * Exp(mulTv + implied_vol * Z) * prod
sum1 = sum1 + spotnext
Next i
mean = sum1 / 6
payoff = Application.Max(mean - K, 0)
payoff_sum = payoff_sum + payoff
secondmoment = secondmoment + payoff * payoff
Next j
Following up on the community wiki answer I posted, a possible solution is this:
Function RndExcludingZero()
Do
RndExcludingZero = Rnd()
Loop While RndExcludingZero = 0
End Function
Usage:
Z = Sqr(time) * Application.NormSInv(RndExcludingZero())
Rnd() returns values >=0 and <1.
At some point it is bound to return 0. When given 0 as input in Excel, NormSInv returns the #NUM!
Excel error.* When called in VBA via Application.NormSInv(0), it returns a Variant of subtype Error with value "Error 2036" (equivalent to the #NUM! Excel error).
Such Variant/Errors cannot be implicitly coerced to a numerical value (which is what the * operator expects) and thus in this case, you will get the type mismatch error.
You will only get this error when Rnd() happens to return 0, which is consistent with your observation that the error occurs only sometimes.
* This was first remarked by user3964075 in a now defunct comment to the question.

Normal Distributed Random Number in VB.NET

Is there anybody know how to make normal distributed random number in vb.net?
thank you
From this forum post :
Usage:
GaussNumDist(Mean, Standard Deviation, Sample Size)
Code example below, which will populate GaussNumArray() with the sample of numbers, whose distribution will have the mean and standard deviation specified:
Imports System.Math
Module Module1
Friend GaussNumArray() As Double
Friend intICell As Long
Friend Function GaussNumDist(ByVal Mean As Double, ByVal StdDev As Double, ByVal SampleSize As Integer)
intICell = 1 'Loop variable
ReDim GaussNumArray(SampleSize)
Do While (intICell < (SampleSize + 1))
Call NumDist(Mean, StdDev)
Application.DoEvents()
Loop
End Function
Sub NumDist(ByVal meanin As Double, ByVal sdin As Double)
'---------------------------------------------------------------------------------
'Converts uniform random numbers over the region 0 to 1 into Gaussian distributed
'random numbers using Box-Muller algorithm.
'Adapted from Numerical Recipes in C
'---------------------------------------------------------------------------------
'Defining variables
Dim dblR1 As Double
Dim dblR2 As Double
Dim mean As Double
Dim var As Double
Dim circ As Double
Dim trans As Double
Dim dblY1 As Double
Dim dblY2 As Double
Dim Pi As Double
Pi = 4 * Atan(1)
'Get two random numbers
dblR1 = (2 * UniformRandomNumber()) - 1
dblR2 = (2 * UniformRandomNumber()) - 1
circ = (dblR1 ^ 2) + (dblR2 ^ 2) 'Radius of circle
If circ >= 1 Then 'If outside unit circle, then reject number
Call NumDist(meanin, sdin)
Exit Sub
End If
'Transform to Gaussian
trans = Sqrt(-2 * Log(circ) / circ)
dblY1 = (trans * dblR1 * sdin) + meanin
dblY2 = (trans * dblR2 * sdin) + meanin
GaussNumArray(intICell) = dblY1 'First number
'Increase intICell for next random number
intICell = (intICell + 1)
GaussNumArray(intICell) = dblY2 'Second number
'Increase intICell again ready for next call of ConvertNumberDistribution
intICell = (intICell + 1)
End Sub
Friend Function UniformRandomNumber() As Double
'-----------------------------------------------------------------------------------
'Outputs random numbers with a period of > 2x10^18 in the range 0 to 1 (exclusive)
'Implements a L'Ecuyer generator with Bays-Durham shuffle
'Adapted from Numerical Recipes in C
'-----------------------------------------------------------------------------------
'Defining constants
Const IM1 As Double = 2147483563
Const IM2 As Double = 2147483399
Const AM As Double = (1.0# / IM1)
Const IMM1 As Double = (IM1 - 1.0#)
Const IA1 As Double = 40014
Const IA2 As Double = 40692
Const IQ1 As Double = 53668
Const IQ2 As Double = 52774
Const IR1 As Double = 12211
Const IR2 As Double = 3791
Const NTAB As Double = 32
Const NDIV As Double = (1.0# + IM1 / NTAB)
Const ESP As Double = 0.00000012
Const RNMX As Double = (1.0# - ESP)
Dim iCell As Integer
Dim idum As Double
Dim j As Integer
Dim k As Long
Dim temp As Double
Static idum2 As Long
Static iy As Long
Static iv(NTAB) As Long
idum2 = 123456789
iy = 0
'Seed value required is a negative integer (idum)
Randomize()
idum = (-Rnd() * 1000)
'For loop to generate a sequence of random numbers based on idum
For iCell = 1 To 10
'Initialize generator
If (idum <= 0) Then
'Prevent idum = 0
If (-(idum) < 1) Then
idum = 1
Else
idum = -(idum)
End If
idum2 = idum
For j = (NTAB + 7) To 0
k = ((idum) / IQ1)
idum = ((IA1 * (idum - (k * IQ1))) - (k * IR1))
If (idum < 0) Then
idum = (idum + IM1)
End If
If (j < NTAB) Then
iv(j) = idum
End If
Next j
iy = iv(0)
End If
'Start here when not initializing
k = (idum / IQ1)
idum = ((IA1 * (idum - (k * IQ1))) - (k * IR1))
If (idum < 0) Then
idum = (idum + IM1)
End If
k = (idum2 / IQ2)
idum2 = ((IA2 * (idum2 - (k * IQ2))) - (k * IR2))
If (idum2 < 0) Then
idum2 = idum2 + IM2
End If
j = (iy / NDIV)
iy = (iv(j) - idum2)
iv(j) = idum
If (iy < 1) Then
iy = (iy + IMM1)
End If
temp = AM * iy
If (temp <= RNMX) Then
'Return the value of the random number
UniformRandomNumber = temp
End If
Next iCell
End Function
End Module
You can use following line
Dim x1 as Double = MathNet.Numerics.Distributions.Normal.Sample(MEAN, STDEV)
Math.Net Numeric package can be installed using following NuGet command
Install-Package MathNet.Numerics -Version 4.9.0
You can found more information on NuGet site