I am writing a program in VBA-excel that is supposed to:
1 - determine how much data is in an array (dynamic array)
2 - based on the number inside the first array, (1 through 3) do a certain calculation (volume of cylinder = 1, volume of cone = 2, and volume of a section of sphere = 3)
3 - based off the number in the first array, the volume is to be printed in column D with the correct calculation
My current program does all of this just fine
The next step is to keep a running total of how many 1's, 2's, and 3's I have (and print them out) and to also keep a running total of each shapes total volume. (i.e. the total volume for all cylinders = xxxx)
again this all updates just fine except the running total of the volumes. the problem I am having is after I run the program once and existing values are in there, i change a number (in any one of the columns) and i have to run the program twice in order to get the correct data to output to the running total volumes.
What I think is happening is the volume in column D (the calculated volume) is not updating before the running total volume takes the number. but in looking at my code i do not understand why the running total volume retrieves that number before the new calculation happens.
Any thoughts on how i could postpone the running total until all the data is populated and then gather all the data?
Here is my current code:
Sub volumecalc()
totalnum = WorksheetFunction.CountA(Range("A2:A1000"))
ReDim Array1(1 To totalnum)
For i = 1 To totalnum
Array1(i) = Cells(i + 1, 1)
Next i
ReDim array2(1 To totalnum)
For j = 1 To totalnum
array2(j) = Cells(j + 1, 2)
Next j
ReDim array3(1 To totalnum)
For k = 1 To totalnum
array3(k) = Cells(k + 1, 3)
Next k
ReDim array4(1 To totalnum)
For p = 1 To totalnum
array4(p) = Cells(p + 1, 4)
Next p
Range("D2:D1000") = Clear
Range("G2:G4") = Clear
Range("H2:H4") = Clear
totalvol = 0
totalvol1 = 0
totalvol2 = 0
Count = 0
count1 = 0
count2 = 0
For i = 1 To totalnum
If Array1(i) = 1 Then
Cells(i + 1, 4) = WorksheetFunction.Pi * array2(i) ^ 2 * array3(i)
Count = Count + 1
Cells(2, 7) = Count
totalvol = totalvol + array4(i)
Cells(2, 8) = totalvol
ElseIf Array1(i) = 2 Then
Cells(i + 1, 4) = (WorksheetFunction.Pi * array2(i) ^ 2 * array3(i)) / 3
count1 = count1 + 1
Cells(3, 7) = count1
totalvol1 = totalvol1 + array4(i)
Cells(3, 8) = totalvol1
ElseIf Array1(i) = 3 Then
Cells(i + 1, 4) = (WorksheetFunction.Pi * array2(i) ^ 2 * array3(i)) / 2 + (WorksheetFunction.Pi * array3(i) ^ 3) / 6
count2 = count2 + 1
Cells(4, 7) = count2
totalvol2 = totalvol2 + array4(i)
Cells(4, 8) = totalvol2
ElseIf Array1(i) < 1 Or Array1(i) > 3 Then
MsgBox ("Not In Correct Range, Try Again")
End If
Next i
For j = 1 To totalnum
If array2(j) <= 0 Then
MsgBox ("Number Must Be Greater Than 0")
End If
Next j
For j = 1 To totalnum
If array3(j) <= 0 Then
MsgBox ("Number Must Be Greater Than 0")
End If
Next j
Cells(5, 7) = Count + count1 + count2
Cells(5, 8) = totalvol + totalvol1 + totalvol2
End Sub
The code is reading the values from column D into array4. Newly calculated values are then written into column D but the various total volume variables get updated with the values from array4. This is why the totals end up with the old values initially and why things work correctly when the program runs again (because array4 gets updated with the new values).
It's not really clear why array4 is needed so just replace the occurrences of:
totalvol = totalvol + array4(i)
with:
totalvol = totalvol + Cells(i + 1, 4).Value
Related
i am trying to make a loop to go through an array(47193, 4) and an array 2 named attack(41892,1). The idea here is that the attack array has the values in order from the sheet i want to later on add the values to the next column, this is why i add the values to a third array. So the loop is going to go one by one the value from attack array while looping through arr array to find the common data. i tried copying the values directly to the sheet but excel freezes a lot. Now with this way, excel still freezes at this point. Is there anything wrong with it?
Dim arr3() As Variant
Dim dee As Long
ReDim arr3(UBound(attacks, 1), 1)
For k = 0 To UBound(attacks, 1)
j = 0
For j = 0 To UBound(arr, 1)
If attacks(k, 0) = arr(j, 0) And attacks(k, 1) = arr(j, 2) Then
arr3(dee, 0) = attacks(k, 0)
arr3(dee, 1) = attacks(k, 1)
de = dee + 1
End If
Next j
Next k
Here's some code showing how to use a Dictionary:
Sub Tester()
Const SZ As Long = 10000 'size of test arrays
Dim arr1(1 To SZ, 1 To 2)
Dim arr2(1 To SZ, 1 To 2)
Dim arr3(1 To SZ, 1 To 2) '<<matches go here
Dim n As Long, m As Long, i As Long, t, dict, k
t = Timer
'fill test arrays with random data
For n = 1 To SZ
arr1(n, 1) = CLng(Rnd * 200)
arr1(n, 2) = CLng(Rnd * 200)
arr2(n, 1) = CLng(Rnd * 200)
arr2(n, 2) = CLng(Rnd * 200)
Next n
Debug.Print "Filled test arrays", Timer - t
t = Timer
'test the nested loop approach
For n = 1 To SZ
For m = 1 To SZ
If arr1(n, 1) = arr2(m, 1) And arr1(n, 2) = arr2(m, 2) Then
i = i + 1
arr3(i, 1) = arr1(n, 1)
arr3(i, 2) = arr1(n, 2)
End If
Next m
Next n
Debug.Print "Finished nested loop", Timer - t, i & " matches"
t = Timer
'create a lookup using a dictionary
Set dict = CreateObject("scripting.dictionary")
For n = 1 To SZ
k = arr1(n, 1) & "|" & arr1(n, 2)
dict(k) = dict(k) + 1
Next n
Debug.Print "Filled dictionary", Timer - t
t = Timer
i = 0
Erase arr3
'Perform the match against arr2 using the dictionary
For m = 1 To SZ
k = arr2(m, 1) & "|" & arr2(m, 2)
If dict.exists(k) Then
i = i + 1
arr3(i, 1) = arr2(m, 1)
arr3(i, 2) = arr2(m, 2)
End If
Next m
Debug.Print "Finished dictionary loop", Timer - t, i & " matches"
End Sub
Output:
Filled test arrays 0
Finished nested loop 9.101563 2452 matches
Filled dictionary 0.03125
Finished dictionary loop 0.0078125 2177 matches
Note the # of matches is slightly different - the nested loop catches duplicate matches but the Dictionary only counts unique matches. You might need to make adjustments depending on your use case.
this is part of my code that i am working with and I have one problem. I have array with values (masyvas) and i started new loop to find other values by using masyvas(i,1) values and after that i need that new values would be printed in masyvas(i,2) and i need to group them. It need to look like this:
991988 Gaz.duon.sk"Giros"gaiv.g.1,5L 5_PETØFLAT1,5
PALINK
117388 Silp.gaz.nat.min.v"Tiche'1,5L 5_PETØFLAT1,5
PALINK
RIMI LIETUVA
ŠIAULIŲ TARA
111388 Gaz.nat.min.v"Tiche" 1,5L pet 5_PETØFLAT1,5
PALINK
AIBĖS LOGISTIKA
AIBĖS LOGISTIKA
RIMI LIETUVA
ŠIAULIŲ TARA
How it looks now from marked 1 it goes wrong
Data sheet where i get array values
Here is part of my code where i have this problem now it prints new values next to masyvas(i,2) but not below as I need.
lastrow2 = Sheets("lapas").Cells(Rows.Count, 1).End(xlUp).Row
rub = lastrow2
cub = 3
ReDim masyvas(1 To rub, 1 To cub)
For i = 1 To rub
For j = 1 To cub
masyvas(i, j) = Sheets("lapas").Cells(i, j).Value 'array gets values from filtered data in AKCIJOS sheet
Next
Next
Sheets("lapas").Range("A1:C100").Clear
For i = 1 To rub Step 1
Set rng2 = grafikas.Cells(6 + h, 2)
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
grafikas.Cells(7 + r, 2).EntireRow.Select
Selection.Insert Shift:=xlDown
grafikas.Cells(7 + r, 3) = akcijos.Cells(m, 3)
r = r + 1
h = r
End If
End If
Next m
For j = 1 To cub Step 1
rng2.Offset(i - 1, j - 1).Value = masyvas(i, j)
Next
Next
You didn't provide any screenshot of your data, so it's hard to say what exactly is your problem and desired output, but try the code below. I marked changed lines.
For i = 1 To rub
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
'masyvas(i, 2) = masyvas(i, 2) & akcijos.Cells(m, 3)
masyvas(i, m) = masyvas(i, m) & akcijos.Cells(m, 3) '<------
End If
End If
Next
For j = 1 To cub
rng2.Offset(j - 1, i - 1).Value = masyvas(i, j) '<-----
Next
Next
Writing rudimentary VBA to populate a 2 dimensional array filled with two sums one consisting of the odd columns the other is the sum of the even columns, totaled over a variable amount of rows stored in another array. the two dimensional array then prints on a seperate worksheet. I wrote code which succesfully completed this task on two other worksheets in the same file with slightly different sized arrays, but it populates the destination range with zeros when adjusted for the new input and output.
code in question:
Sub dad()
Dim i As Integer, j As Integer, units As Double, value As Double, mr(1 To 655, 1 To 3) As Double, u As Integer, here As Range
Dim thisone As String, there As Range
thisone = Worksheets("MB52 for 1010").Cells(1, 1).Address
Set here = Range(thisone)
MsgBox (here(1, 1).Address)
thisone = Worksheets("1010totals").Cells(1, 1).Address
Set there = Range(thisone)
MsgBox (there(1, 1).Address)
For i = 1 To 655
mr(i, 1) = Worksheets("1010totals").Cells(i + 1, 4).value
Next i
MsgBox ("array made")
i = 1
u = 1
MsgBox (i & " " & u)
For i = 1 To 655
For j = 1 To mr(i, 1)
u = u + 1
units = here(u, 6) + here(u, 9) + here(u, 11).value + here(u, 13) + here(u, 15) + here(u, 17)
value = here(u, 8) + here(u, 10) + here(u, 12).value + here(u, 14) + here(u, 16) + here(u, 18)
Next j
mr(i, 2) = units
mr(i, 3) = value
Next i
For i = 1 To 655
For j = 2 To 3
Worksheets("1010totals").Cells(i + 1, j).value = mr(i, j)
Next j
Next i
End Sub
Original code that works on the other worksheets:
Sub ded()
Dim i As Integer, j As Integer, units As Double, value As Double, n As Integer, mr(1 To 756, 1 To 3) As Double, u As Integer, here As Range
Dim thisone As String, there As Range
thisone = Worksheets("MB52 for 1030").Cells(1, 1).Address
Set here = Range(thisone)
MsgBox (here(1, 1).Address)
thisone = Worksheets("1030totals").Cells(1, 1).Address
Set there = Range(thisone)
MsgBox (there(1, 1).Address)
For i = 1 To 756
mr(i, 1) = Worksheets("1030totals").Cells(i + 1, 4).value
Next i
MsgBox ("array made")
i = 1
u = 1
MsgBox (i & " " & u)
For i = 1 To 756
For j = 1 To mr(i, 1)
u = u + 1
units = here(u, 6) + here(u, 9) + here(u, 11).value + here(u, 13) + here(u, 15) + here(u, 17)
value = here(u, 8) + here(u, 10) + here(u, 12).value + here(u, 14) + here(u, 16) + here(u, 18)
Next j
mr(i, 2) = units
mr(i, 3) = value
Next i
For i = 1 To 756
For j = 2 To 3
Worksheets("1030totals").Cells(i + 1, j).value = mr(i, j)
Next j
Next i
End Sub
I want to copy a set of values from an array than meet the condition (values < 70 for example) to the next column
'Qo reported (bd) - array
For i = 0 To cap
array_Qorep(i, 0) = Range("A" & i + 1)
Cells(i + 1, 3) = array_Qorep(i, 0) 'copy array in the next column
If Cells(i + 1, 1).Value = Empty Then Exit For 'more values below, stop in blank
Next
the problem is that i don't know how to apply the condition i want in the array and then copying to the next column, is there a way to delete the values that doesn't meet the condition from the array and then copy them?
here is the solution for some reason it didnt work before but now it does :)
, and thanks Absinthe
'Qo reported (bd)
For i = 0 To cap
array_Qorep(i, 0) = Range("A" & i + 1)
If Cells(i + 1, 1).Value = Empty Then Exit For
If array_Qorep(i, 0) > Cells(3, 4) Then
Cells(i + 1, 3) = array_Qorep(i, 0)
End If
Next
Does this do it? Build your array first then:
arrPos = 1
For x = 0 to myArray.length
if myArray(x,0) < 70 then
cells(arrPos, 1) = myArray(x, 0)
arrPos = arrPos + 1
End If
next x
*******Background*******
For reasons not up for debate I am using Excel 2010 and VBA to program a scientific model that involves a user inputting data to a worksheet from an online data bank for each species involved. The number of species may change from simulation to simulation. As the program iterates, it calls many functions multiple times (some in the tens of thousands of times). The execution speed of the program is becoming too long so I would like to try and speed it up. In my mind two easy things to increase the execution speed are to decrease the number of worksheet calls and to minimize the number of variants I have to use.
Also of note that several of the functions share the same constants.
I've looked elsewhere on stackexchange and other sites but I still haven't found what I'm looking for ♪. Maybe I just don't have the right search terms.
The question(s)
Because the number of species is not constant and because I would like to make a few arrays of constants available to multiple functions is there away that I can define say a global variable that is an double (or single) precision array that is dimensionalized when a sub is run, reads the constants from the excel sheet once, and then is destroyed when my "main" sub is finished executing?
I could create the array(s) in the main sub and pass it as an argument but several of my functions call other functions as arguments already and several of my lines are extremely long and hard to read. By making these constants arguments to pass to the functions only increases the length of these lines.
Second question if I can't create a global array variable is there away to call the worksheet once (like I have done) but to make the variable a double instead of a variant? I couldn't get the following to work because of the type mismatch error.
Dim C() As Double
redim c(1 to 7, 1 to n)
C = Application.Transpose(Worksheets("Viscosity2").Range("J10:p19"))
Function example: I have a function that I am running in VBA. This function is called tens of thousands of times in the course of my program. I would like to make the C(1 to 7, 1 to n) array and the mw(1 to n) array double precision arrays that call the worksheet once and then are available to multiple functions.
Below is that example function:
Function mumx(y, T)
'this function calculates the mixture viscosity using the Chapman Enskog Wilke method
'using the mol fraction vector, y, and the temperature T
n = UBound(y, 1) - LBound(y, 1) + 1 'number of species
'***********Get Equation Parameters from Worksheet**************
Dim C() As Variant
C = Application.Transpose(Worksheets("Viscosity2").Range("J10:p19"))
Dim mw As Variant
mw = Application.Transpose(Worksheets("Viscosity2").Range("g10:g19"))
'***************************************************************
Dim mu() As Double
ReDim mu(1 To n)
For i = 1 To n Step 1
mu(i) = (C(1, i) * (T ^ C(2, i))) / (1 + C(3, i) / T + (C(4, i) / (T ^ 2)))
Next i
Dim phi() As Double
ReDim phi(1 To n, 1 To n)
For i = 1 To n
For j = 1 To n
phi(i, j) = 1 / 8 ^ 0.5 * (1 + mw(i) / mw(j)) ^ -0.5 * (1 + (mu(i) / mu(j)) ^ 0.5 * (mw(j) / mw(i)) ^ 0.25) ^ 2
test = 1
Next j
Next i
Dim denom As Double
Dim mumix As Double
denom = 0
mumix = 0
For i = 1 To n
For j = 1 To n
denom = denom + y(j) * phi(i, j)
Next j
mumix = mumix + y(i) * mu(i) / denom
denom = 0
Next i
mumx = mumix
'where the units on mumx are in units of cP (which are 1 gm/(m*s))
End Function
'************Example constants are as follows********
'PS should someone stumble on this looking for say viscosity data
'the following constants just example constants
'
'
'C(1, 1) = 0.00018
'C(1, 2) = 0.000017
'C(1, 3) = 0.001113
'C(1, 4) = 0.00215
'C(1, 5) = 0.0005255
'C(1, 6) = 0.0011
'C(1, 7) = 0.0006559
'C(1, 8) = 0.00005
'C(1, 9) = 0.00026
'C(1, 10) = 0.002079
'
'C(2, 1) = 0.69
'C(2, 2) = 1.115
'C(2, 3) = 0.534
'C(2, 4) = 0.46
'C(2, 5) = 0.59
'C(2, 6) = 0.563
'C(2, 7) = 0.608
'C(2, 8) = 0.90
'C(2, 9) = 0.68
'C(2, 10) = 0.4163
'
'C(3, 1) = -0.59
'C(3, 2) = 0
'C(3, 3) = 94.7
'C(3, 4) = 290.
'C(3, 5) = 106.
'C(3, 6) = 96.3
'C(3, 7) = 54.7
'C(3, 8) = 0
'C(3, 9) = 98.9
'C(3, 10) = 353.
'
'C(4, 1) = 140.
'C(4, 2) = 0
'C(4, 3) = 0
'C(4, 4) = 0
'C(4, 5) = 0
'C(4, 6) = 0
'C(4, 7) = 0
'C(4, 8) = 0
'C(4, 9) = 0
'C(4, 10) = 0
'
'
'C(5, 1) = 0
'C(5, 2) = 0
'C(5, 3) = 0
'C(5, 4) = 0
'C(5, 5) = 0
'C(5, 6) = 0
'C(5, 7) = 0
'C(5, 8) = 0
'C(5, 9) = 0
'C(5, 10) = 0
'
'C(6, 1) = 300
'C(6, 2) = 300
'C(6, 3) = 300
'C(6, 4) = 300
'C(6, 5) = 300
'C(6, 6) = 300
'C(6, 7) = 300
'C(6, 8) = 300
'C(6, 9) = 300
'C(6, 10) = 300
'
'C(7, 1) = 1000
'C(7, 2) = 1000
'C(7, 3) = 1000
'C(7, 4) = 1000
'C(7, 5) = 1000
'C(7, 6) = 1000
'C(7, 7) = 1000
'C(7, 8) = 1000
'C(7, 9) = 1000
'C(7, 10) = 1000
'
'
'
'mw(1) = 2.0158
'mw(2) = 18.0148
'mw(3) = 28.01
'mw(4) = 44.009
'mw(5) = 16.0426
'mw(6) = 31.998
'mw(7) = 28.014
'mw(8) = 44.0962
'mw(9) = 30.0694
'mw(10) = 28.0536
'
''******************************
Yes, you can and should* use an array to store the constants entered by the user and yes, you can make it global so that it doesn't have to be passed to the other functions.
Here's an example; note that the data is read into a Variant first, then transferred to the array--this was your missing step that lead to the Type Mismatch error. While this may look like too much code for the effort, transferring the data into the Double array will be many times faster than reading the cells one-by-one.
Public C() As Double
Public Sub PopulateArrayC(n As Integer)
ReDim C(1 To 7, 1 To n)
Dim v As Variant
v = Application.Transpose(Worksheets("Viscosity2").Range("J10:P" & n + 10 - 1))
Dim i As Integer, j As Integer
For i = 1 To 7
For j = 1 To n
C(i, j) = v(i, j)
Next j
Next i
End Sub
*Reading from and writing to cells is very time consuming. Whenever possible, limit the number of reads and writes by*
storing frequently used values in variables, and
reading/writing whole ranges at a time.