Public Function APortfolioReturnsXL1(Returns As Range, Weights As Range) As Double()
On Error GoTo errHandler
Dim arrReturns() As Double
Dim arrWeights() As Double
Dim TotRows As Double
Dim TotCols As Double
Dim RowCtr As Double
Dim Colctr As Double
Dim WgtColctr As Double
Dim WgtRows As Double
TotRows = Returns.Rows.Count
TotCols = Returns.Columns.Count
WgtRows = Weights.Rows.Count
ReDim arrReturns(1 To TotRows, 1 To TotCols)
For RowCtr = 1 To TotRows
For Colctr = 1 To TotCols
arrReturns(RowCtr, Colctr) = Val(Returns.Cells(RowCtr, Colctr).Value)
Next
Next
ReDim arrWeights(1 To WgtRows, 1 To 1)
For WgtColctr = 1 To WgtRows
arrWeights(WgtColctr) = Val(Weights.Cells(WgtColctr, 1).Value)
Next
APortfolioReturnsXL1 = APortfolioReturns(arrReturns(), arrWeights())
Exit Function
errHandler:
MsgBox "An error has occurred." & vbCrLf & Err.Description & vbCrLf & CStr(Err.Number)
End Function
I am getting an
error subscript out of range
.
it doesnt enter the loop in the this line:
For WgtColctr = 1 To WgtRows
arrWeights(WgtColctr) = Val(Weights.Cells(WgtColctr, 1).Value)
Next
You are trying to assign value to a 2D array.
Use: arrWeights(WgtColctr, 1) = Val(Weights.Cells(WgtColctr, 1).Value)
Instead of: arrWeights(WgtColctr) = Val(Weights.Cells(WgtColctr, 1).Value)
Related
I am getting a runtime error on this exact line.
Range("Aqual").Offset(0, i).Interior.color = rg.Offset(0, i + 11).Interior.color
I am simply trying to match color of a range in one worksheet to another range in a different worksheet. I have tried various troubleshooting rewrites of this line and tried to contain this out into a separate sub and it still fails. (I have these troubleshooting lines commented out and they all also fail.) I still can't get it and have wasted days trying to figure this out. The Range("Aqual") is a named range in sheet1 "F8". The for loop is so it moves across 6 columns. My worksheets are not protected nor is my workbook.
Option Explicit
Dim rg As Range
Dim i As Integer
Function posABC(ByVal A As String, ByVal B As String, ByVal C As String, ByVal D As String, ByVal G As Integer) As String
On Error GoTo errormsg
Application.EnableEvents = False
Dim output As String
Dim code As String
Dim priKVA As String
Dim secKVA As String
Dim readCode As String
Dim secOffset As Integer
Dim writeRange As Range
Dim readRange As Range
output = "empty code"
code = A & B & C
If G >= 0 And G <= 3 Then
secOffset = 0
Else
secOffset = G - 3
End If
For Each rg In Range("tblPosA")
readCode = rg.Value & rg.Offset(0, 1).Value & rg.Offset(0, 2).Value
If readCode = code Then
priKVA = rg.Offset(0, 4).Value
If D = "1" Then
secKVA = rg.Offset(1, 5 + secOffset).Value
Else
secKVA = rg.Offset(0, 5 + secOffset).Value
End If
For i = 0 To 5
Range("Aqual").Offset(0, i).Interior.color = rg.Offset(0, i + 11).Interior.color
' Set writeRange = Range("Aqual").Offset(0, i)
' Set readRange = rg.Offset(0, i + 11)
' writeRange.Interior.color = readRange.Interior.color
' Call matchColor(Range("Aqual").Offset(0, i), rg.Offset(0, i + 11))
' Range("F8").Interior.color = RGB(0, 255, 0)
' Select Case True
' Case rg.Offset(0, i + 11).Interior.color = vbRed
' Range("Aqual").Offset(0, i).Interior.color = vbRed
' Case rg.Offset(0, i + 11).Interior.color = vbGreen
' Range("Aqual").Offset(0, i).Interior.color = vbGreen
' Case rg.Offset(0, i + 11).Interior.color = vbYellow
' Range("Aqual").Offset(0, i).Interior.color = vbYellow
' End Select
Next i
Exit For
End If
Next rg
output = "Primary kVA= " & priKVA & vbNewLine & "Secondary kVA= " & secKVA
posABC = output
Application.EnableEvents = True
errormsg:
MsgBox Err.Description & " " & Err.Number
End Function
If use this sub for the operation it still fails.
Sub matchColor(ByVal writeRange As Range, ByVal readRange As Range)
writeRange.Interior.color = readRange.Interior.color
End Sub
And for some reason I don't know. This sub does work when I was trying to isolate the failure.
Sub colortest()
Dim writeRange As Range
Dim readRange As Range
Dim rg As Range
Set rg = Sheet7.Range("L6")
Set writeRange = Range("Aqual").Offset(0, 0)
Set readRange = rg.Offset(0, i)
writeRange.Interior.color = readRange.Interior.color
End Sub
Excel spreadsheet
I have a set of over 10,000 lines of text strings in column A (Input), and I need to get the number (in case there is only one) or a sum of both (in case there are two).
Code
Here is the VBA code I have:
Sub ExtractNumericStrings()
Dim rngTemp As Range
Dim strTemp As String
Dim currNumber1 As Currency
Dim currNumber2 As Currency
Dim lngTemp As Long
Dim lngPos As Long
Dim lngLastRow As Long
With ActiveSheet
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rngTemp In .Cells(1, "A").Resize(lngLastRow, 1) ' Set Range to look at
strTemp = rngTemp.Value2 ' Get string value of each cell
lngTemp = Len(strTemp) 'Get length of string
currNumber1 = 0 ' Reset value
currNumber2 = 0 ' Reset value
' Get first number
currNumber1 = fncGetNumericValue(strTemp, 1) ' Strip out first number
' Get second number if exists
' First strip out first number
strTemp = Replace(strTemp, currNumber1, "")
If Len(strTemp) <> 0 Then
currNumber2 = fncGetNumericValue(strTemp, 1)
End If
' now paste to sheet
If currNumber1 <> 0 And currNumber2 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1 + currNumber2
rngTemp.Offset(0, 2).Value = "sum of the numbers"
ElseIf currNumber1 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1
End If
Next rngTemp
End With
Call MsgBox("Procedure Complete!", vbOKOnly + vbInformation, "Procedure Complete")
End Sub
Private Function fncGetNumericValue(strTemp As String, lngStart As Long) As Currency
Dim varTemp As Variant
Dim lngCount As Long
Dim lngTemp As Long
' Reset
lngCount = 1
lngTemp = 1
varTemp = ""
On Error Resume Next
If IsNumeric(Left(strTemp, lngCount)) Then
Do While IsNumeric(Left(strTemp, lngCount)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
Else
' First clear non-numerics from string
lngTemp = 1
Do While IsNumeric(Left(strTemp, 1)) = False
lngTemp = lngTemp + 1
strTemp = Mid(strTemp, 2, Len(strTemp) - 1)
If lngTemp > Len(strTemp) Then
Exit Do
End If
Loop
' Then extract second number if exists
If strTemp <> "" Then
Do While IsNumeric(Mid(strTemp, lngCount, 1)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
End If
End If
' Retrun Value
If IsNumeric(varTemp) Then
fncGetNumericValue = CCur(varTemp)
Else
fncGetNumericValue = 0
End If
End Function
Here is what I'm trying to do:
https://www.youtube.com/watch?v=EjHnJVxuWJA
I have very limited knowledge of VBA, so please excuse me if I ask any stupid question. Running this thing successfully will save me hips of time. thanks!
Something like this:
Private Sub extract_num()
Dim cell as Range
Dim ws as Worksheet: Set ws = Sheets("Sheet1") ' replace Sheet1 with ur sheet name
Dim lr as Long: Set lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim values() As String
Dim i as Byte
Dim temp as Double
For Each cell in ws.Range("A2:A" & lr)
If Not isEmpty(cell) Then
values = Split(cell, " ")
For i = LBound(values) to UBound(values)
values(i) = Replace(values(i), ",", ".")
If isNumeric(values(i)) Then
temp = temp + values(i)
End If
Next i
cell.Offset(0, 2) = temp
temp = 0
End If
Next cell
End Function
This is presuming:
a) Individual words and numbers are always separated by space "123 abc 321"
b) Commas "," are used as an arithmetic floatpoint separator ##,##
Slightly different approach from Rawrplus
Option Explicit
Sub UpdateTotals()
Dim aRawValues As Variant
Dim iLRow&, iRow&, iArr&
Dim dTotal#
With ThisWorkbook.Worksheets("Sheet1") '<-- Change the sheet name to your sheet
iLRow = .Cells(Rows.Count, 1).End(xlUp).Row ' Get row count
For iRow = 1 To iLRow ' Loop through all rows in the sheet
aRawValues = Split(.Range("A" & iRow).Value, " ") ' Create and array of current cell value
For iArr = LBound(aRawValues) To UBound(aRawValues) ' Loop through all values in the array
dTotal = dTotal + ReturnDouble(Replace(aRawValues(iArr), ",", ".")) ' Add the returned double to total
Next
.Range("B" & iRow).Value = dTotal ' Set value in column B
dTotal = 0# ' Reset total
Next
End With
End Sub
Function ReturnDouble(ByVal sTextToConvert As String) As Double
Dim iCount%
Dim sNumbers$, sCurrChr$
sNumbers = ""
For iCount = 1 To Len(sTextToConvert)
sCurrChr = Mid(sTextToConvert, iCount, 1)
If IsNumeric(sCurrChr) Or sCurrChr = "." Then
sNumbers = sNumbers & sCurrChr
End If
Next
If Len(sNumbers) > 0 Then
ReturnDouble = CDbl(sNumbers)
Else
ReturnDouble = 0#
End If
End Function
I am trying to build a collection and take the Count of Unique Values from that Collection but am getting an error in building a Collection itself. Can anyone suggest me where I am going wrong. Kindly Share your thoughts. Please let me know how to find out the COUNT of UNIQUE VALUES as well.
Sub trial()
Dim sampleVisualBasicColl As Collection
For i = 2 To 10
Rng = Range("M" & i).value
StartsWith = Left(Rng, 3)
If StartsWith = "Joh" Then
sampleVisualBasicColl.Add Rng
Else
End If
Next
Debug.Print (sampleVisualBasicCol1)
End Sub
Using a collection you can just add Joh to the collection and then count the items:
'Using a collection
Sub Col_test()
Dim cCol As Collection
Dim i As Long
Set cCol = New Collection
On Error GoTo Err_Handler
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Left(.Cells(i, 13), 3) = "Joh" Then
cCol.Add .Cells(i, 13).Value, .Cells(i, 13).Value
End If
Next i
End With
Debug.Print cCol.Count
On Error GoTo 0
Exit Sub
Err_Handler:
Select Case Err.Number
Case 457 'This key is already associated with an element of this collection
Err.Clear
Resume Next
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure Col_test."
Err.Clear
End Select
End Sub
If you want the count of each item (Joh, Ben... whatever else you have) then use a dictionary:
'Using a dictionary.
Sub Dic_Test()
Dim dict As Object
Dim i As Long
Dim sValue As String
Dim key As Variant
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Len(.Cells(i, 13)) >= 3 Then
sValue = Left(.Cells(i, 13), 3)
If dict.exists(sValue) Then
dict(sValue) = dict(sValue) + 1
Else
dict(sValue) = 1
End If
End If
Next i
End With
For Each key In dict.keys
Debug.Print key & " = " & dict(key)
Next key
End Sub
Note: I'm using Cells within the code rather than Range. Cells(2,13) is M2 (13th column, 2nd row).
I find this link very helpful with dictionaries: https://excelmacromastery.com/vba-dictionary/
As a further update (after answer accepted) and using the lists you gave in your question here: Excel VBA - Formula Counting Unique Value error this code with dictionaries will return Joh = 4, Ian = 3
'Using a dictionary.
Sub Dic_Test()
Dim dict As Object
Dim dictFinal As Object
Dim i As Long
Dim sValue As String
Dim key As Variant
Dim keyFinal As String
Set dict = CreateObject("Scripting.Dictionary")
Set dictFinal = CreateObject("Scripting.Dictionary")
'Get the unique values from the worksheet.
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Len(.Cells(i, 13)) >= 3 Then
sValue = .Cells(i, 13).Value
If dict.exists(sValue) Then
dict(sValue) = dict(sValue) + 1
Else
dict(sValue) = 1
End If
End If
Next i
End With
'Count the unique values in dict.
For Each key In dict.keys
keyFinal = Left(key, 3)
If dictFinal.exists(keyFinal) Then
dictFinal(keyFinal) = dictFinal(keyFinal) + 1
Else
dictFinal(keyFinal) = 1
End If
Next key
For Each key In dictFinal.keys
Debug.Print key & " = " & dictFinal(key)
Next key
End Sub
You need to create the collection as well as declaring it.
Sub trial()
Dim myCol As Collection
Set myCol= New Collection ' creates the collection
For i = 2 To 10
Rng = Range("M" & i).value
StartsWith = Left(Rng, 3)
If StartsWith = "Joh" Then
myCol.Add Rng
Else
End If
Next
For each x in myCol
Debug.Print x
Next x
End Sub
Hey this code will help u since it's collecting Unique values in Listbox,,
Private Sub UserForm_Initialize()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Set sh = ThisWorkbook.Sheets("Sheet1")
Set Rng = sh.Range("A2", sh.Range("A2").Value ="John". End(xlDown))
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
Me.ListBox1.AddItem vNum
Next vNum
End Sub
You have not declared Variable Rng & i these are the most important thing to do. Meanwhile I would like to suggest this Formula,,
=Sum(if(Frequency (if(Len(B2 :B20) >0,Match(B2 :B20, B2 :B20, 0),""),if(Len(B2 :B20) >Match(B2 :B20, B2 :B20, 0),"",))>0,1))
Its Array formula so finish with Ctrl +shift +enter.
You can use this one also,
Sub CountUnique()Dim i, count, j As Integer count = 1 For i = 1 To 470 flag = False If count
1 Then For j = 1 To count If Sheet1.Cells(i,
3).Value = Sheet1.Cells(j, 11).Value Then flag
= True End If Next j Else flag = False End If If flag = False Then Sheet1.Cells(count,
11 ).Value = Sheet1.Cells(i, 3).Value count = count + 1 End IfNext i Sheet1.Cells( 1 ,
15 ).Value = count End Sub
i am trying to get multiple vlookup in single cell
I am getting #VALUE! error with the below function, Need help to correct the code
MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer)
Dim i As Long
Dim Result As String
For i = 1 To LookupRange.Columns(1).Cells.Count
If LookupRange.Cells(i, 1) = Lookupvalue Then
For J = 1 To i - 1
If LookupRange.Cells(J, 1) = Lookupvalue Then
If LookupRange.Cells(J, ColumnNumber) = LookupRange.Cells(i, ColumnNumber) Then
GoTo Skip
End If
End If
Next J
Result = Result & " " & LookupRange.Cells(i, ColumnNumber) & ","
Skip:
End If
Next i
MultipleLookupNoRept = Left(Result, Len(Result) - 1)
End Function
This code works for me. Most of it is the original code.
Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer) As String
Dim i As Long
Dim Result As String
For i = 1 To LookupRange.Columns(1).Cells.Count
If LookupRange.Cells(i, 1) = Lookupvalue Then
Result = Result & " " & LookupRange.Cells(i, ColumnNumber) & ","
End If
Next i
If (Len(Result) = 0) Then
MultipleLookupNoRept = 0
Else
MultipleLookupNoRept = Left(Result, Len(Result) - 1)
End If
End Function
'This code should help
' Syntax =MVLOOKUP(Lookup_value,Table_array,Col_index_number)
Option Explicit
Function mvlookup(lookupValue, tableArray As Range, colIndexNum As Long, _
Optional NotUsed As Variant) As Variant
Dim initTable As Range
Dim myRowMatch As Variant
Dim myRes() As Variant
Dim myStr As String
Dim initTableCols As Long
Dim i As Long
Dim ubound_myRes As Long
Set initTable = Nothing
On Error Resume Next
Set initTable = Intersect(tableArray, _
tableArray.Parent.UsedRange.EntireRow)
On Error GoTo 0
If initTable Is Nothing Then
mvlookup = CVErr(xlErrRef)
Exit Function
End If
initTableCols = initTable.Columns.Count
i = 0
Do
myRowMatch = Application.Match(lookupValue, initTable.Columns(1), 0)
If IsError(myRowMatch) Then
Exit Do
Else
i = i + 1
ReDim Preserve myRes(1 To i)
myRes(i) _
= initTable(1).Offset(myRowMatch - 1, colIndexNum - 1).Text
If initTable.Rows.Count <= myRowMatch Then
Exit Do
End If
On Error Resume Next
Set initTable = initTable.Offset(myRowMatch, 0) _
.Resize(initTable.Rows.Count - myRowMatch, _
initTableCols)
On Error GoTo 0
If initTable Is Nothing Then
Exit Do
End If
End If
Loop
If i = 0 Then
mvlookup = CVErr(xlErrNA)
Exit Function
End If
myStr = ""
For i = LBound(myRes) To UBound(myRes)
myStr = myStr & ", " & myRes(i)
Next i
mvlookup = Mid(myStr, 3)
End Function
I have a string which is in A1 of Sheet1 and it refreshes regularly.
it looks like this -
{"rows":[{"advances":637,"declines":836,"unchanged":76,"total":1549}],"success":"true","results":1}
I want to extract numeric values 637 and 836 and 76 and store it in separate columns. The values keeps on changing, like 637 can be sometimes 1200.
I want a VBA code, not an user defined function to automatically extract the numeric data and store it.
I am using this code, but I am not getting anything. What is wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v
End If
Range("=Sheet1!$E$1:$G$1").Copy Destination:=Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1)
Sheets("Updated").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Now
End Sub
While I would be tempted to use standard functions for this you could run a VBA UDF like so
to get the first match from A1 (as a number)
=RegexMatches(A1,1)
the second match
=RegexMatches(A1,2)
and so on
The UDF returns "No Match" where no matches are found, or a message "Less than X matches" if you try to extract a match from a position that doesb't exist
Function RegexMatches(strIn As String, LngPos As Long)
Dim objRegex
Dim objRegexMC
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = ":(\d+),"
If .test(strIn) Then
Set objRegexMC = .Execute(strIn)
If objRegexMC.Count >= LngPos Then
RegexMatches = CLng(objRegexMC(LngPos - 1).submatches(0))
Else
RegexMatches = "Less than " & LngPos & " matches"
End If
Else
RegexMatches = "No Match"
End If
End With
End Function
[Update: added sheet event code]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Set rng1 = Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
'set row1 as first row if it is blank
If rng1.Row = 2 And rng1.Offset(-1, 0) = vbNullString Then Set rng1 = rng1.Offset(-1, 0)
rng1.Resize(1, 3).Value = Range("B1:D1").Value
rng1.Offset(0, -1).Value = Now
End Sub
You can use an instance of the windows script control to parse the text for you:
Sub Tester()
Dim JSON As String
Dim sc As Object
JSON = "{""rows"":[{""advances"":637,""declines"":836," & _
"""unchanged"":76,""total"":1549}]" & _
",""success"":""true"",""results"":1}"
'JSON = ActiveSheet.Range("A1").Value
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.Eval "var o = eval(" & JSON & ")" 'evaluate to an object
Debug.Print "success", sc.Eval("o.success")
Debug.Print "#results", sc.Eval("o.results")
Debug.Print " advances", sc.Eval("o.rows[0].advances")
Debug.Print " declines", sc.Eval("o.rows[0].declines")
Debug.Print " unchanged", sc.Eval("o.rows[0].unchanged")
End Sub
I needed something similar and developed the following code. I have no doubts that it could be made more sophisticated but it provided me with the required result.
Dim cr_ref As String ' Original reference - alpha and numer
Dim new_ref As String ' Resultant numeirc only reference
Dim iAsciiCode As Integer
Dim sCount As Integer ' Length of reference
cr_ref = Trim(Cells(4, 19).Value) ' Get reference from source
sCount = Len(cr_ref)
new_ref = "" ' Start with empty result
For i = 0 To sCount - 1 ' Strip out all except digits
iAsciiCode = Asc(Mid(cr_ref, i + 1, 1)) ' Give me Ascii code
If iAsciiCode >= 48 And iAsciiCode <= 57 Then ' I only want 0-9
new_ref = new_ref & Mid(cr_ref, i + 1, 1) ' Append numeric digit
End If
Next i
' Result is in new_ref
This works:
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v