This question already has an answer here:
Incorrect result from CurrentRegion when used in a function called from a cell
(1 answer)
Closed 2 years ago.
I have a UDF as detailed below. When I step through the formula by calling it in a Sub and using a msgbox to return the result, I end up with the correct result. So it appears to work fine. however, when I use as a UDF in a cell of the worksheet, I get #VALUE as a result. What am I missing?
Function ToolStatus(PartNumber As String, Model As String, Number As Integer) As String
Dim SearchSheet As Worksheet
Dim PN As Long
Dim MdlCol As Long
Dim Mdl As String
Dim Result As Long
Dim SearchArray As Variant
Dim PartCount As Long
Dim i As Long
Application.Volatile True
ToolStatus = ""
PartCount = WorksheetFunction.CountA(Sheet2.Range("A:A"))
Select Case True
Case Number < PartCount And Model = "1A"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 5
Mdl = "1A"
Result = 20
Case Number < PartCount And Model = "1B"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 6
Mdl = "1B"
Result = 20
Case Number < PartCount And Model = "1C"
Set SearchSheet = Sheet2
PN = 3
MdlCol = 7
Mdl = "1C"
Result = 20
Case Number >= PartCount And Model = "1A"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 18
Mdl = "-1A"
Result = 5
Case Number >= PartCount And Model = "1B"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 19
Mdl = "-1B"
Result = 5
Case Number >= PartCount And Model = "1C"
Set SearchSheet = Sheet3
PN = 2
MdlCol = 20
Mdl = "-1C"
Result = 5
End Select
SearchArray = SearchSheet.Range("A1").CurrentRegion
For i = LBound(SearchArray, 1) To UBound(SearchArray, 1)
If SearchArray(i, PN) = PartNumber And SearchArray(i, MdlCol) = Mdl Then
ToolStatus = SearchArray(i, Result)
Exit For
End If
Next i
End Function
As #BigBen pointed out, the .CurrentRegion was the issue. I replaced SearchArray = SearchSheet.Range("A1").CurrentRegion with SearchArray = SearchSheet.Range("A1:CD2000").Value just to test and it worked. SO I need to figure out how to make the range adjust, but now I know the issue was CurretnRegion.
Related
I want to use the vba sumifs array and scripting.dictionary because there are a hundred thousand records there may be the best solution. For information sheet "DBALL" is the source and sheet "RECON" is the result. I also found the vba code below but it doesn't match the result.
info formula sheet "RECON" column B "In" = SUMIFS(DBALL!$A$2:$A$5,DBALL!$C$2:$C$5,RECON!$A2,DBALL!$B$2:$B$5,RECON!B$1)
info formula sheet "RECON" column c "Out" = SUMIFS(DBALL!$A$2:$A$5,DBALL!$C$2:$C$5,RECON!$A2,DBALL!$B$2:$B$5,RECON!C$1)
info formula sheet "RECON" column d "difference" = B2-C2
Thanks
Sub SUMIFSFASTER()
Dim arr, ws, rng As Range, keyCols, valueCol As Long, destCol As Long, i As Long, frm As String, sep As String
Dim t, dict, arrOut(), arrValues(), v, tmp, n As Long
keyCols = Array(2, 3) 'these columns form the composite key
valueCol = 1 'column with values (for sum)
destCol = 4 'destination for calculated values
t = Timer
Set ws = Sheets("DBALL")
Set rng = ws.Range("A1").CurrentRegion
n = rng.Rows.Count - 1
Set rng = rng.Offset(1, 0).Resize(n) 'exclude headers
'build the formula to create the row "key"
For i = 0 To UBound(keyCols)
frm = frm & sep & rng.Columns(keyCols(i)).Address
sep = "&""|""&"
Next i
arr = ws.Evaluate(frm) 'get an array of composite keys by evaluating the formula
arrValues = rng.Columns(valueCol).Value 'values to be summed
ReDim arrOut(1 To n, 1 To 1) 'this is for the results
Set dict = CreateObject("scripting.dictionary")
'first loop over the array counts the keys
For i = 1 To n
v = arr(i, 1)
If Not dict.exists(v) Then dict(v) = Array(0, 0) 'count, sum
tmp = dict(v) 'can't modify an array stored in a dictionary - pull it out first
tmp(0) = tmp(0) + 1 'increment count
tmp(1) = tmp(1) + arrValues(i, 1) 'increment sum
dict(v) = tmp 'return the modified array
Next i
'second loop populates the output array from the dictionary
For i = 1 To n
arrOut(i, 1) = dict(arr(i, 1))(1) 'sumifs
'arrOut(i, 1) = dict(arr(i, 1))(0) 'countifs
'arrOut(i, 1) = dict(arr(i, 1))(1) / dict(arr(i, 1))(0) 'averageifs
Next i
'populate the results
rng.Columns(destCol).Value = arrOut
Debug.Print "Checked " & n & " rows in " & Timer - t & " secs"
End Sub
Source
RESULT
As said in the comments a better solution is probably to use a pivot table resp. power pivot.
If you are after a solution with VBA and want to use a dictionary I would probably use the following code.
First you need to create a class cVal which stores the values you are after
Option Explicit
Public qtyIn As Double
Public qtyOut As Double
Then you can use the following code
Option Explicit
Sub useDict()
Const COL_VAL = 1
Const COL_INOUT = 2
Const COL_COMBINE = 3
Const GRO_IN = "IN"
Const GRO_OUT = "OUT"
Dim rg As Range, ws As Worksheet
' Get the range with the data
Set ws = Worksheets("DBALL")
Set rg = ws.Range("A1").CurrentRegion
Set rg = rg.Offset(1, 0).Resize(rg.Rows.Count - 1)
Dim vDat As Variant
vDat = rg
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim Key As Variant, gro As Variant
Dim i As Long, sngVal As cVal
For i = LBound(vDat, 1) To UBound(vDat, 1)
' Key of the dictionary
Key = vDat(i, COL_COMBINE)
' trim the value and do not consider upper/lower case
gro = UCase(Trim(vDat(i, COL_INOUT)))
If dict.Exists(Key) Then
' just increase the "member" values of the already stored object
Set sngVal = dict(Key)
With sngVal
If gro = GRO_IN Then
.qtyIn = .qtyIn + vDat(i, COL_VAL)
End If
If gro = GRO_OUT Then
.qtyOut = .qtyOut + vDat(i, COL_VAL)
End If
End With
Else
' Create a new object which stores the summed values for "IN" resp "OUT"
Set sngVal = New cVal
With sngVal
If gro = GRO_IN Then
.qtyIn = vDat(i, COL_VAL)
End If
If gro = GRO_OUT Then
.qtyOut = vDat(i, COL_VAL)
End If
End With
dict.Add Key, sngVal
End If
Next i
' write Dictionary
' put the values of the dictionary in an array
' this is faster than writing each single line directly to the sheet
ReDim vDat(1 To dict.Count, 1 To 4)
i = 1
For Each Key In dict.Keys
vDat(i, 1) = Key
vDat(i, 2) = dict(Key).qtyIn
vDat(i, 3) = dict(Key).qtyOut
vDat(i, 4) = Abs(dict(Key).qtyIn - dict(Key).qtyOut)
i = i + 1
Next Key
'write Header
Set rg = Worksheets("RECON").Range("A1")
Set rg = rg.Resize(, 4)
rg.Clear
rg = Array("COMBINE", "In", "Out", "Diff")
Set rg = Worksheets("RECON").Range("A2")
Set rg = rg.Resize(dict.Count, 4)
rg.Clear
rg = vDat
' PS Code to add a sum row below the data
Set rg = Worksheets("RECON").Range("A" & dict.Count + 2)
Set rg = rg.Resize(1, 4)
rg.Clear
'rg.Columns(1).Value = "Total"
Dim bSum As Double, rDat As Variant
rDat = Application.Index(vDat, , 2)
bSum = WorksheetFunction.sum(rDat)
rg.Columns(2).Value = bSum
rDat = Application.Index(vDat, , 3)
bSum = WorksheetFunction.sum(rDat)
rg.Columns(3).Value = bSum
rDat = Application.Index(vDat, , 4)
bSum = WorksheetFunction.sum(rDat)
rg.Columns(4).Value = bSum
End Sub
But I doubt that to be faster than a Pivot Table
I want to create a function plot_array(arr As Variant) which will create plot based on element in array.
On x axis I want to have numbers 1, 2,.., n which are indexes of array elements, and on y axis I want to have values stored in array. In other words
Example
Dim arr(9) As Variant
arr(0) = 0
arr(1) = 1
arr(2) = 5
arr(3) = 1
arr(4) = 5
arr(5) = 5
arr(6) = 1
arr(7) = 7
arr(8) = 6
plot_array(arr)
I tried to figure it about by running Macros and thinking how can I generalize this code to be working for any array, but I end up with nothing. Is there any possibility how it can be done ?
Try the next code, please. It will create a chart (xlLine type) and feed it with the array. You can change in the line .SeriesCollection.NewSeries.Values = arr1 arr1 with arr and obtain the same thing, if you put all the used number in the range "A1:A9":
Sub testPlotChartArray()
Dim sh As Worksheet, cH As Chart, arr1, arr(1 To 9)
Set sh = ActiveSheet
arr1 = sh.Range("A1:A9").Value
arr(1) = 0: arr(2) = 1: arr(3) = 5: arr(4) = 1: arr(5) = 5
arr(6) = 5: arr(7) = 1: arr(8) = 7: arr(9) = 6
On Error Resume Next
Set cH = sh.ChartObjects("PlotChart").Chart
If Err.Number = 0 Then
Err.Clear
cH.Parent.Delete
End If
On Error GoTo 0
Set cH = sh.ChartObjects.Add(left:=60, top:=10, width:=300, height:=300).Chart
With cH
.Parent.Name = "PlotChart"
.ChartType = xlLine
.SeriesCollection.NewSeries.Values = arr1 'or arr
End With
End Sub
The above code deletes the chart if it exists, but it can be configured to use the same existing chart and feed its .SeriesCollection(1).Values...
If you declare an array as arr(9) in Excel, the index is declared as a total of 10 arrays from 0 to 9, so your array is not the correct number.
Sub test()
Dim arr(8) As Variant
arr(0) = 0
arr(1) = 1
arr(2) = 5
arr(3) = 1
arr(4) = 5
arr(5) = 5
arr(6) = 1
arr(7) = 7
arr(8) = 6
plot_array (arr)
End Sub
Sub plot_array(arr As Variant)
Dim Srs As Series
Dim Cht As Chart
Dim xAxes As Axis, yAxes As Axis
Dim i As Integer, vX() As Variant
ReDim vX(LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
vX(i) = i + 1 '<~~ if index start from 0 then delete +1
Next i
Set Cht = ActiveSheet.Shapes.AddChart.Chart
With Cht
.HasTitle = True
.ChartTitle.Text = "My Graph"
.ChartType = xlXYScatterLinesNoMarkers
For Each Srs In .SeriesCollection
Srs.Delete
Next Srs
Set Srs = .SeriesCollection.NewSeries
With Srs
.Name = "item"
.Values = arr
.XValues = vX
.MarkerStyle = xlCircle
End With
Set xAxes = .Axes(xlCategory, xlPrimary)
With xAxes
.MinimumScale = 0
.MaximumScale = WorksheetFunction.Max(vX)
.MajorUnit = 1
.HasMajorGridlines = True
End With
Set yAxes = .Axes(xlValue, xlPrimary)
With yAxes
.MinimumScale = 0
.MaximumScale = WorksheetFunction.Max(arr) + 1
.MajorUnit = 1
.HasMajorGridlines = True
End With
End With
End Sub
I have a loop, and I want to put the result into array.
Here is my loop.
For i = 1 To bill
a = rs("CT08_Tarikh") 'from db
cutiumum = Array(a) 'and this is how I declare array
rs.MoveNext
Next
rs.Close
Set rs = Nothing
End If
and after that, i will pass the variable to another function:
tarikh = NetWorkdays(dateFrom, dateTo, cutiumum)
Public Function NetWorkdays(dtStartDate, dtEndDate, arrHolidays)
but, when I try to do some loop for arrHolidays inside the function NetWorkdays, it only return 1 data (not all from the cutiumum).
What do you think is my mistake?
Update
I'm already using
dim arrRecordset
arrRecordset = rs.GetRows()
but I got an error inside the function
Public Function NetWorkdays(dtStartDate, dtEndDate, arrHolidays)
Dim lngDays
Dim lngSaturdays
Dim lngSundays
Dim lngHolidays
Dim lngAdjustment
Dim dtTest
Dim i, x
lngDays = DateDiff("d", dtStartDate, dtEndDate)
lngSundays = DateDiff("ww", dtStartDate, dtEndDate, vbSunday)
lngSaturdays = DateDiff("w", IIf(Weekday(dtStartDate, vbSunday) = vbSaturday, dtStartDate, dtStartDate - Weekday(dtStartDate, vbSunday)), dtEndDate)
For x = LBound(arrHolidays) To UBound(arrHolidays)
For i = 0 To lngDays
dtTest = DateAdd("d", i, dtStartDate)
'error in line here: Subscript out of range: 'arrHolidays'
If arrHolidays(x) = dtTest And Weekday(dtTest) <> 1 And Weekday(dtTest) <> 7 Then
lngHolidays = lngHolidays + 1
End If
Next
Next
If Weekday(dtStartDate, vbSunday) = vbSunday Or Weekday(dtStartDate, vbSunday) = vbSaturday Then
lngAdjustment = 0
Else
lngAdjustment = 1
End If
NetWorkdays = lngDays - lngSundays - lngSaturdays - lngHolidays + lngAdjustment
End Function
Try this:
dim arrRecordset
arrRecordset = rs.GetRows()
The getRows() method will transform a recordset into a two dimensional array in one go:
https://www.w3schools.com/asp/met_rs_getrows.asp
How do I reference an array address where the WorksheetFunction.Max has found the largest value within the array? There can be multiple highs within the array.
Dim myArraySum(1 to 4) as long
Dim myArrayAddress(1 to 4) as integer
myArraySum(1) = 2
myArraySum(2) = 5
myArraySum(3) = 7
myArraySum(4) = 7
myArrayHigh = Application.WorksheetFunction.Max(myArraySum)
myArrayAddress = 'code needed
My desired output is
myArrayHigh = 7
myArrayAddress(1) = 3
myArrayAddress(2) = 4
The most straightforward way is to use a loop to check the values of every array element.
Function GetMaxIndicesArray(ByRef myArraySum() As Long, ByRef myArrayAddress() As Integer) As Integer
Dim i As Integer, j As Integer, iLow As Integer, iUp As Integer
Dim lMax As Long
iLow = LBound(myArraySum)
iUp = UBound(myArraySum)
lMax = Application.WorksheetFunction.Max(myArraySum)
j = 1
For i = iLow To iUp
If (myArraySum(i) = lMax) Then
myArrayAddress(j) = i
j = j + 1
End If
Next
GetMaxIndicesArray = j - 1
End Function
Sub test()
Dim myArraySum(1 To 4) As Long
Dim myArrayAddress(1 To 4) As Integer
Dim i As Integer, n As Integer
myArraySum(1) = 2
myArraySum(2) = 5
myArraySum(3) = 7
myArraySum(4) = 7
myArrayHigh = Application.WorksheetFunction.Max(myArraySum)
'myArrayAddress = "" 'code needed
n = GetMaxIndicesArray(myArraySum, myArrayAddress)
Debug.Print "myArrayHigh = " & myArrayHigh
For i = 1 To n
Debug.Print "myArrayAddress(" & i & ") = " & myArrayAddress(i)
Next
End Sub
Then in you debugger window, just type
test
The Result is like:
myArrayHigh = 7
myArrayAddress(1) = 3
myArrayAddress(2) = 4
Use a simple loop:
Sub dural()
Dim myArraySum(1 To 4) As Long
Dim myArrayAddress(1 To 4) As Integer
Dim myArrayHigh As Long, k As Long, msg As String
myArraySum(1) = 2
myArraySum(2) = 5
myArraySum(3) = 7
myArraySum(4) = 7
myArrayHigh = Application.WorksheetFunction.Max(myArraySum)
k = 1
For i = LBound(myArraySum) To UBound(myArraySum)
If myArraySum(i) = myArrayHigh Then
myArrayAddress(k) = i
k = k + 1
End If
Next i
msg = ""
For i = LBound(myArrayAddress) To UBound(myArrayAddress)
msg = msg & vbCrLf & i & vbTab & myArrayAddress(i)
Next i
MsgBox msg
End Sub
I am trying to have my code prompt the user to select a range of data of 3 width and variable length. There will only be 30 values those with some rows being blank. I want to have these 30 values populate into 30 text boxes in a userform of mine (this is so values don't have to be manually entered). I looked around and figured my route should be Application.Inputbox and then pass it into an array were the blank rows can be weeded out with for loops. I don't know how to pass the user selected table into a 2D array though.
Sub selectRange()
Dim r(1 To 14, 1 To 3) As Variant, ran As Range, calB(1 To 30) As Long, i As Integer, j As Integer, k As Integer, l As Integer
dozerCal.Hide
Set r = Application.InputBox("Select the Cal B table.", Type:=8)
For j = 1 To 14
For i = 1 To 3
If Abs(r(j, i)) > 0 Then
calB(l) = r(j, i)
l = l + 1
End If
Next
Next
lx = calB(1)
ly = calB(2)
lz = calB(3)
rx = calB(4)
ry = calB(5)
rz = calB(6)
ix = calB(7)
iy = calB(8)
iz = calB(9)
sx = calB(10)
sy = calB(11)
sz = calB(12)
p1x = calB(13)
p1y = calB(14)
p1z = calB(15)
p2x = calB(16)
p2y = calB(17)
p2z = calB(18)
lfx = calB(19)
lfy = calB(20)
lfz = calB(21)
lrx = calB(22)
lry = calB(23)
lrz = calB(24)
rfx = calB(25)
rfy = calB(26)
rfz = calB(27)
rrx = calB(28)
rry = calB(29)
rrz = calB(30)
ActiveWorkbook.Close
dozercall.Show
End Sub
Thanks in advance for everyone's help.
Edit: I missed that you were using the input box wrong, however I will leave this answer as it presents a way to collapse a variable range of user input from a multidimensional array into a single dimension array.
This should get you started. Basically it will read the user's input, dynamically create a one-dimensional array of the correct size (rows * columns), and read all the values in the range the user selects to this one dimensional array. It will then loop through the one dimensional array and print the values back out to the window.
I think this is what you're looking for, but if you need further clarification I can add some. I added comments so you can see what each section is doing.
Option Explicit
Private Sub TestArrays()
Dim calBTemp() As Variant, calB() As Variant
Dim i As Long, j As Long, x As Long
Dim rngInput As Range
Set rngInput = Application.InputBox("Select the Cal B table.", "Select Range", Type:=8)
'Read the user input, check for empty input
'If empty input, exit the subroutine
If Not rngInput Is Nothing Then
calBTemp = rngInput
Else
Exit Sub
End If
'Create the one-dimensional array dynamically based on user selection
ReDim calB((UBound(calBTemp, 1) - LBound(calBTemp, 1) + 1) * (UBound(calBTemp, 2) - LBound(calBTemp, 2) + 1))
'Loop through our multidimensional array
For i = LBound(calBTemp, 1) To UBound(calBTemp, 1)
For j = LBound(calBTemp, 2) To UBound(calBTemp, 2)
'Assign the value to our one dimensional array
calB(x) = calBTemp(i, j)
x = x + 1
Next j
Next i
'Loop through our one dimensional array
For i = LBound(calB) To UBound(calB)
Debug.Print calB(i)
Next i
End Sub
So I just wasn't using the Application.Inputbox right. If you return it as a range it will configure to the proper sized 2D array it seams and you can call/manipulate data from there. Here is a working sub.
Sub selectRange()
Dim ran As Range, calB(1 To 30) As Double, i As Integer, j As Integer, k As Integer, l As Integer
dozerCal.Hide
Set ran = Application.InputBox("Select the Cal B table.", Type:=8)
l = 1
For j = 1 To 14
For i = 1 To 3
If Abs(ran(j, i)) > 0 Then
calB(l) = ran(j, i)
l = l + 1
End If
Next
Next
lx = calB(1)
ly = calB(2)
lz = calB(3)
rx = calB(4)
ry = calB(5)
rz = calB(6)
ix = calB(7)
iy = calB(8)
iz = calB(9)
sx = calB(10)
sy = calB(11)
sz = calB(12)
p1x = calB(13)
p1y = calB(14)
p1z = calB(15)
p2x = calB(16)
p2y = calB(17)
p2z = calB(18)
lfx = calB(19)
lfy = calB(20)
lfz = calB(21)
lrx = calB(22)
lry = calB(23)
lrz = calB(24)
rfx = calB(25)
rfy = calB(26)
rfz = calB(27)
rrx = calB(28)
rry = calB(29)
rrz = calB(30)
ActiveWorkbook.Close
dozerCal.Show
End Sub
This code will do the trick (and forces the user to select 3 columns and 14 rows):
Sub selectRange()
Dim selectedRange As Range
Dim errorMessage As String
errorMessage = vbNullString
Dim ran As Range, calB(1 To 30) As Long, i As Integer, j As Integer, k As Integer, l As Integer
Do
'doesn't handle cancel event
Set selectedRange = Application.InputBox("Select the Cal B table.", _
Type:=8, Title:="Please select 14 rows and 3 columns" & errorMessage)
errorMessage = "; previous selection was invalid"
Loop While selectedRange.Columns.Count <> 3 Or selectedRange.Rows.Count <> 14
For j = 1 To 14
For i = 1 To 3
If Abs(selectedRange.Cells(j, i)) > 0 Then
calB(l) = selectedRange.Cells(j, i)
l = l + 1
End If
Next
Next
...rest of your code