Below I am trying to write a script the goal of which is to calculate some summary statistics for a few different columns of numbers. I have gotten some help on it up to the "Need help below" mark. But beyond that I am flabergasted as to how to calculate the simple stats (sum, mean, standard deviation, coefficient of variation). I know VB has scripts for these stats, which I have included in my code, but I guess I need to do some extra declaring or something. Advice much appreciated. Thanks.
Sub TOAinput()
Const n As Integer = 648
Dim stratum(n), hybrid(n), acres(n), hhsz(n), offinc(n)
Dim s1 As Integer
Dim s2 As Integer
Dim i As Integer
For i = 1 To n
stratum(i) = Worksheets("hhid level").Cells(i + 1, 2).Value
Next i
s1 = 0
s2 = 0
For i = 1 To n
If stratum(i) = 1 Then
s1 = s1 + 1
Else:
s2 = s2 + 1
End If
Next i
Dim acres1(), hhsz1(), offinc1(), acres2(), hhsz2(), offinc2()
ReDim acres1(s1), hhsz1(s1), offinc1(s1), acres2(s2), hhsz2(s2), offinc2(s2)
'data infiles: acres, hh size, off-farm income,
For i = 1 To n
acres(i) = Worksheets("hhid level").Cells(i + 1, 4).Value
hhsz(i) = Worksheets("hhid level").Cells(i + 1, 5).Value
offinc(i) = Worksheets("hhid level").Cells(i + 1, 6).Value
Next i
s1 = 0
s2 = 0
For i = 1 To n
If stratum(i) = 1 Then
s1 = s1 + 1
acres1(s1) = acres(i)
hhsz1(s1) = hhsz(i)
offinc1(s1) = offinc(i)
Else:
s2 = s2 + 1
acres2(s2) = acres(i)
hhsz2(s2) = hhsz(i)
offinc2(s2) = offinc(i)
End If
Next i
'****************************
'Need help below
'****************************
Dim sumac1, sumac2, mhhsz1, mhhsz2, cvhhsz1, cvhhsz2
sumac1 = Sum(acres1)
sumac2 = Sum(acres2)
mhhsz1 = Average(hhsz1)
mhhsz2 = Average(hhsz2)
cvhhsz1 = StDev(hhsz1) / Average(hhsz1)
cvhhsz2 = StDev(hhsz2) / Average(hhsz2)
End Sub
Sum, Average and StdDev are worksheet functions and cannot be used directly in VBA.
Try
MyInteger = Application.WorksheetFunction.Sum(MyIntegerArray)
if Nick Sabbe's suggestion that you place formulae in cells is inappropriate.
Related
I have a working loop which is supposed to deal with dates in a big quantity (final result has 15 columns with 30K+ rows in each) and script is looping for considerable amount of time (30+ minutes).
I am looking for better way of looping through dataset (different loop type - For Each?, arrays?, avoiding collections?).
DataSet example - Yellow cells are static data I am dealing with, Green cells is desirable result
I am looping from lastrow to firstrow in Column A and putting results to columns E and F.
My current loop consists of For Next and Collections and code is as follows:
Set FindCol = ws.Range("1:1").Find(What:="Difference")
FindColNumber = FindCol.Column
lastc = FindColNumber
lastr = ws.Cells(ws.Rows.count, lastc).End(xlUp).Row
lastr2 = Cells(Rows.count, lastc).End(xlUp).Row
For P = lastr2 To 3 Step -1
lastr2 = P
lastr = P
For R = lastr To 3 Step -1
lastr = R
Set DatePosition = Cells(lastr2, lastc - 4)
Set DatePosition2 = Cells(lastr - 1, lastc - 4)
If col.count = 0 Then
col.Add DatePosition
Else: col.Add DatePosition, Before:=1
End If
If col2.count = 0 Then
col2.Add DatePosition
Else: col2.Add DatePosition2, Before:=1
End If
Next R
Next P
lastc2 = ws.Cells(2, ws.Columns.count).End(xlToLeft).Column + 1
lastr4 = ws.Cells(ws.Rows.count, lastc2).End(xlUp).Row
cnt = lastr4 + 1
For Each col_element In col
ws.Cells(cnt, lastc2) = col_element
cnt = cnt + 1
Next
Set col = New Collection
lastc2 = ws.Cells(2, ws.Columns.count).End(xlToLeft).Column + 1
lastr4 = ws.Cells(ws.Rows.count, lastc2).End(xlUp).Row
cnt = lastr4 + 1
For Each col_element In col2
ws.Cells(cnt, lastc2) = col_element
cnt = cnt + 1
Next
Set col2 = New Collection
I am currently trying to use vba to check whether a solver solution has been found already and if so generate a new one. Below is my code. There are comments to explain what is going on.
Sub Button1_Click()
Dim i As Integer
Dim j As Integer
one = 1
min_cell = Range("BF6").Value
max_cell = Range("BF7").Value
gamer = Range("BF10").Value
Dim players(1 To 200) As String 'here is the inner array
Dim lineups(1 To 200) As Variant 'here is the outer array
For i = 1 To 200
lineups(i) = players 'assigning the players array to each spot in the lineup array
Next i
If gamer = 0 Then
spot = "AZ3"
accuracy = 0.00000001
ElseIf gamer = 1 Then
spot = "BA3"
accuracy = 0.001
End If
Dim variable As Integer
lineup_quantity = Range("BF8").Value 'denotes how many different solutions the solver should generate
max_value = 1000
Dim counter As Integer
Dim count As Integer
lineup_number = 1 'denotes the current lineup number
Dim occurences(1 To 201) As Integer
For count = lineup_number To lineup_quantity 'running solver
Dim positions(1 To 201) As String
Dim cell_numbers(1 To 201)
track = 1
Worksheets("Draftkings Lookup").Range("AI1:AI500").Copy
Worksheets("Draftkings Lookup").Range("DZ1:DZ500").PasteSpecial Paste:=xlPasteValues
SolverReset
solverok setcell:=spot, maxminval:=1, bychange:="AL" + CStr(min_cell) + ":AL" + CStr(max_cell), engine:=2
SolverOptions Precision:=accuracy
solveradd cellref:="AL" + CStr(min_cell) + ":AL" + CStr(max_cell), relation:=5
solveradd cellref:=spot, relation:=1, formulatext:=max_value
solveradd cellref:="BA6:BA11", relation:=2, formulatext:="AY6"
solversolve userfinish:=True
Range("BM" + CStr(count + 1)).Value = Range(spot).Value
For counter = min_cell To max_cell
If Range("AL" + CStr(counter)).Value = 1 Then
players(track) = Range("B" + CStr(counter)).Value 'stores the result to of the solver and is working properly
positions(track) = Range("C" + CStr(counter)).Value
cell_numbers(track) = counter
track = track + 1
End If
Next counter
For counter = 1 To lineup_number 'my attempt at comparing players to each array in lineups which is not working
For i = 1 To 8
If lineups(counter)(i) <> players(i) Then
GoTo hi
End If
Next i
count = count - 1 'causes program to repeat current lineup
GoTo line
hi:
Next counter
For i = 1 To 8
lineups(lineup_number)(i) = players(i) 'adding the current players as an array in lineups since they don't match any prior lineups
Next i
line:
Worksheets("Draftkings Lookup").UsedRange.Columns("AI:AI").Calculate
Next count
End Sub
I am still getting duplicates when I run it for a large number of lineups like 40. Any help would be greatly appreciated.
I'm trying to find an index of the minimum value from sum(3) array. And it should be assigned to a variable min
min = index of minimum value
Should I sort the array first or is there any direct way of doing it?
Here is my code:
`Sub Min_index()
Dim Pt_array(3) As Single
Pt_array(0) = 0
Pt_array(1) = 12.3
Pt_array(2) = 16.06
Pt_array(3) = 20.11
Dim Ad_E_array(3) As Single
Dim Lo_E_array(3) As Single
Dim Bs_temp As Single
Dim i As Integer
i = 0
Do While i < 4
Bs_temp = BS
Ad_E_array(i) = Ad_E 'defined in previous Sub
Lo_E_array(i) = Lo_E 'defined in previous Sub
If Bs_temp + Pt_array(i) - Qth < BS_Maximum_limit Then
Bs_temp = Bs_temp + Pt_array(i) - Qth
Ad_E_array(i) = Ad_E_array(i) + 0
Lo_E_array(i) = Lo_E_array(i) + 0
Call function_decide(int_forecast_hour - 1, Bs_temp, Qth + 1, Lo_E_array(i), Ad_E_array(i))
Else
Lo_E_array(i) = Pt_array(i) - Qth - (BS_Maximum_limit - Bs_temp)
Bs_temp = BS_Maximum_limit
Call function_decide(int_forecast_hour - 1, Bs_temp, Qth + 1, Lo_E_array(i), Ad_E_array(i))
End If
i = i + 1
Loop
Dim sum(3) As Single
Dim min As Single
i = 0
Do While i < 4
sum(i) = Abs(Lo_E_array(i)) + Abs(Ad_E_array(i))
i = i + 1
Loop
End Sub`
You can receive the 1-based index position of the element containing the minimum value with the an Excel Application object's use of the worksheet's MIN function and MATCH function.
Sub wqewuiew()
Dim Pt_array(3) As Single, p As Long
Pt_array(0) = 1000
Pt_array(1) = 12.3
Pt_array(2) = 16.06
Pt_array(3) = 20.11
p = Application.Match(Application.Min(Pt_array), Pt_array, 0)
Debug.Print p '<~~ 'p' is 2 (I changed the value of the first array element)
End Sub
I am putting data in my array I created in VBA.
I wrote some formulas in the macro but when I paste them it is not working.
Sub Button3_Click()
Application.Calculation = xlManual
'update list of document
'declare variables
Dim i As Long
Dim m As Long
Dim n As Long
Dim j As Long
Dim lNumColumn As Long
Dim XLsheetD As String
Dim range_data As String
Dim tab_data()
Dim Data As ListObject
Dim track_list As ListObject
'ini Data
Set Data = Sheets("track_list").ListObjects("sheets_list")
Set track_list = Sheets("track_list").ListObjects("track_list")
Application.Goto Reference:=track_list
Column = ActiveCell.Column
Row = ActiveCell.Row - 1
range_data = "A9:A6000"
'import list
m = Data.ListRows.Count
nb_docs_prev = 0
n = 0
lNumColumn = Application.CountA(Sheets("track_list").Range("B6:Z6"))
For k = 1 To lNumColumn
If Range("B6").Offset(0, k - 1) = "manual" Then
GoTo nextcol
End If
n = 0
For i = 1 To m
XLsheetD = Data.DataBodyRange(i, 1)
lNumCases = Application.CountA(Sheets(XLsheetD).Range(range_data))
nb_docs = lNumCases - 1
c = Data.DataBodyRange(i, k + 1)
If c = "-" Then
n = n + lNumCases
GoTo nextsheet
End If
If k = 1 Then
ReDim Preserve tab_data(lNumColumn, nb_docs + nb_docs_prev + 1)
End If
For j = 0 To nb_docs
If Range("B6").Offset(0, k - 1) = "hyperlink" Then
tab_data(k - 1, n) = ""
Else
tab_data(k - 1, n) = Sheets(XLsheetD).Range("A9").Offset(j, c - 1)
End If
n = n + 1
Next j
nb_docs_prev = nb_docs + nb_docs_prev + 1
nextsheet:
Next i
nextcol:
Next k
'Put data in order
lNumCases = track_list.ListRows.Count
'==>test if data already in the table
For p = 1 To n
For q = 1 To lNumCases
If track_list.DataBodyRange(q, 1) = tab_data(0, p - 1) Then
For r = 1 To lNumColumn
If Range("B6").Offset(0, r - 1) = "manual" Or Range("B6").Offset(0, r - 1) = "semi-automatic" Then
If tab_data(r - 1, p - 1) <> "" Then
Else
tab_data(r - 1, p - 1) = track_list.DataBodyRange(q, r).Formula
End If
End If
Next r
End If
Next q
Next p
' formulas for new lines
For p = 1 To n
tab_data(5 - 1, p - 1) = "=IF([#[DCN no]]<>"""",INDEX(DCN!R9C3:R229C3,MATCH([#[DCN no]],DCN!R9C1:R229C1,0)),"""")"
tab_data(11 - 1, p - 1) = "=IF([#[DCN no]]<>"""",IF(INDEX(DCN!R9C7:R229C7,MATCH([#[DCN no]],DCN!R9C1:R229C1,0))<>"""",""CLOSED"",""OPEN""),"""")"
Next p
'paste list
Application.Goto Reference:=track_list
Selection.ClearContents
track_list.Resize Range(Cells(Row, Column), Cells(Row + n, Column + track_list.ListColumns.Count - 1))
Application.Goto Reference:=track_list
Selection = Application.Transpose(tab_data())
Application.Calculation = xlAutomatic
End Sub
Do you know why ?
Before doing that my macro was working. It is just those formulas impossible to paste.
Thanks
Your statement
Range("S8:AY250") = Application.Transpose(tab_data())
Can only be used to write the values of tab_data to the worksheet
You need to explicitly write your array formula to the worksheet via the method Bruce Wayne identified.
Range("S8").formulaArray = "=IF([#[DCNno]]<>"""",INDEX(DCN!R9C3:R229C3,MATCH([#[DCNno]],DCN!R9C1:R229C1,0)),"""")"
Will get you closer to where you want to be, but the above cell reference is undoubtedly wrong, and I can't determine which cell you actually need, since you're using variables in your array elements
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