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
Related
Thanks for your helps,
I have two arrays: A (100k row, 10 col) and B (100k row, 12 col)
The following code (thanks to BSALV) loop through A and B => It takes really long to finish. Is there any way to speedup.
ReDim Preserve B(1 To UBound(B), 1 To UBound(B, 2) + 4)
ReDim arr(1 To UBound(B), 1 To 2)
For i = 1 To UBound(B)
iSell = B(i, 3): mysold = 0
r = Application.Match(B(i, 2), Application.Index(A, 0, 2), 0)
If IsNumeric(r) Then
For i1 = r To UBound(A)
If A(i1, 2) = B(i, 2) And A(i1, 1) <= B(i, 1) Then
x = Application.Max(0, Application.Min(A(i1, 3), iSell))
If x > 0 Then
mysold = mysold + x
iSell = iSell - x
MyValueSold = MyValueSold + x * A(i1, 4)
A(i1, 3) = A(i1, 3) - x
If A(i1, 3) <= 0 Then A(i1, 2) = "~"
End If
If A(i1, 3) > 0 Then Exit For
End If
Next
End If
arr(i, 1) = mysold: arr(i, 2) = MyValueSold
Next
This operation is really slow when using larger arrays:
r = Application.Match(B(i, 2), Application.Index(A, 0, 2), 0)
You can get much better performance just by replacing the Index/Match line with a dictionary lookup.
To illustrate:
Sub Tester()
Const NROWS As Long = 100000
Dim i As Long, r, t
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim A(1 To NROWS, 1 To 10)
'populate some dummy data
For i = 1 To UBound(A, 1)
A(i, 2) = Application.RandBetween(1, NROWS)
A(i, 3) = i
Next i
'First your existing row lookup...
t = Timer
For i = 1 To 100 'only testing 100 lookups (too slow for more!)
r = Application.Match(i, Application.Index(A, 0, 2), 0)
Next i
Debug.Print "Index/Match lookup", Timer - t, "*100* lookups"
'populate a dictionary for lookups...
t = Timer
For i = 1 To NROWS
dict(A(i, 2)) = i 'mapping second column first occurences to row #
Next i
Debug.Print "Mapping done", Timer - t
'Now the dictionary lookup
t = Timer
For i = 1 To NROWS
If dict.Exists(i) Then
r = dict(i)
End If
Next i
Debug.Print "Dictionary lookup", Timer - t, NROWS & " lookups"
End Sub
Output:
Index/Match lookup 9.62 *100* lookups '<<< slow slow!
Mapping done 0.12
Dictionary lookup 0.26 100000 lookups
EDIT: changes in your existing code
Dim rngMatch As Range '<<< added
'...
'...
Set lo = Sheets("Exc").ListObjects("TBL_Buy")
Set rngMatch = lo.DataBodyRange.Columns(2) '<<< lookup range
With lo.Range
.Sort .Range("B1"), xlAscending, , .Range("A1"), xlAscending, Header:=xlYes
aBuy = lo.DataBodyRange.Value2
.Sort .Range("A1"), xlAscending, , .Range("B1"), xlAscending, Header:=xlYes
End With
'...
For i = 1 To UBound(aResult)
'...
r = Application.Match(aResult(i, 2), rngMatch, 0) '<<<
'...
'...
I initially asked this question How to loop through a specific row of a 2-dimensional Array?
and #FaneDuru was kind enough to supply a solution but now I am hoping I can take it one step further and use a 3 dimensional array in order to obtain the item numbers needed for the second iteration I will be required to do. Initially I thought I would asssume the second iteration was the same as the first and just multiply my results by 2 but I would prefer using a 3-d Array in my solution. Here is what I got. I do not know how to display the results of the other index/iteration?
Dim SWArray() As Variant
ReDim SWArray(1 To 5, 1 To 10, 1 To 2)
SWArray(1, 1) = "Bay1"
SWArray(1, 2) = "Bay2"
SWArray(1, 3) = "Bay3"
SWArray(1, 4) = "Bay4"
SWArray(1, 5) = "Bay5"
SWArray(1, 6) = "Bay6"
SWArray(1, 7) = "Bay7"
SWArray(1, 8) = "Bay8"
SWArray(1, 9) = "Bay9"
SWArray(1, 10) = "Bay10"
SWArray(2, 1) = Bay1
SWArray(2, 2) = Bay2
SWArray(2, 3) = Bay3
SWArray(2, 4) = Bay4
SWArray(2, 5) = Bay5
SWArray(2, 6) = Bay6
SWArray(2, 7) = Bay7
SWArray(2, 8) = Bay8
SWArray(2, 9) = Bay9
SWArray(2, 10) = Bay10
'Loop through bays to assign purlin, girt and
'formboard item numbers per the dimension
For k = LBound(SWArray, 3) To UBound(SWArray, 3)
For i = LBound(SWArray, 2) To UBound(SWArray, 2)
If SWArray(2, i) = 0 Then
SWArray(2, i) = 0
SWArray(3, i) = 0
SWArray(4, i) = 0
ElseIf SWArray(2, i) > 6 And SWArray(2, i) <= 10 Then
SWArray(2, i) = 2035
SWArray(3, i) = 2754
SWArray(4, i) = 2004
ElseIf SWArray(2, i) > 10 And SWArray(2, i) <= 12 Then
SWArray(2, i) = 2036
SWArray(3, i) = 2755
SWArray(4, i) = 2005
ElseIf SWArray(2, i) > 12 And SWArray(2, i) <= 14 Then
SWArray(2, i) = 2037
SWArray(3, i) = 2756
SWArray(4, i) = 2006
ElseIf SWArray(2, i) > 14 And SWArray(2, i) <= 16 Then
SWArray(2, i) = 2038
SWArray(3, i) = 2757
SWArray(4, i) = 2007
End If
Next i
Next k
Worksheets("Data").Range("A55").Resize(UBound(SWArray),
UBound(SWArray, 2)).Value = SWArray
The next piece of code will show how a 3D array is loaded and how its elements will be extracted by iteration. In order to make the example eloquent, please prepare two Excel sheets, in the workbook keeping the next code (ThisWorkbook), named Test_1 and Test_2. Please, place 10 (different) headers on their first row and fill 5 rows of each with different values. Then, copy the next code in a standard module and run it:
Sub testIterate3DArrayExcelExample()
Dim SWArray(1 To 5, 1 To 10, 1 To 2)
Dim wb As Workbook, iRow As Long, iCol As Long, iSht As Long
Set wb = ThisWorkbook
For iRow = 1 To UBound(SWArray, 1)
For iCol = 1 To UBound(SWArray, 2)
For iSht = 1 To UBound(SWArray, 3)
SWArray(iRow, iCol, iSht) = wb.Worksheets("Test_" & iSht).cells(iRow, iCol)
Next iSht
Next iCol
Next iRow
Dim i As Long, j As Long, k As Long
For i = 1 To UBound(SWArray, 1)
For j = 1 To UBound(SWArray, 2)
For k = 1 To UBound(SWArray, 3)
Debug.Print "Sheet Test_" & k & ", Column " & j & ", Row " & i & ": " & SWArray(i, j, k)
Next k
Next j
Next i
End Sub
You can see that for the last dimension all the previous two dimension elements must exist.
So SWArray(1, 1) = "Bay1" does not make any sense..
I am waiting for your clarification regarding what you want accomplishing and I will try helping with a different solution.
If something not clear enough in the above code/sheets preparations, do not hesitate to ask for clarifications.
Edited:
Looking to the previous question and your comments, I tried deducing what you really want accomplishing and I would like to propose the next solution. It involves extending the second array dimension (columns) with an element (which can be 1 or 2) (I mean 11 columns instead of 10 and the last one to be the ID for selecting between the two situations), iterate by columns excepting the last one, and fill two separate arrays according to this last element value. The processed result for each array will be returned starting from "M1") (first processed array) and starting from "X1" the second one:
Sub analizeBaysTwoOptions()
Dim sh As Worksheet, SWArray(), SWArray1(), SWArray2(), i As Long
Dim k1 As Long, k2 As Long
Set sh = ActiveSheet: k1 = 1: k2 = 1
'last column element (in K:K) column, should be the idendifier for the two situations:
SWArray = sh.Range("A1:K4").value 'only to easily test the concept
ReDim SWArray1(1 To UBound(SWArray), 1 To UBound(SWArray, 2) - 1) '- 1 to except the last element
ReDim SWArray2(1 To UBound(SWArray), 1 To UBound(SWArray, 2) - 1) '- 1 to except the last element
For i = LBound(SWArray, 2) To UBound(SWArray, 2) - 1 '- 1 to exclude last column from iteration
If SWArray(1, UBound(SWArray, 2)) = 1 Then
If SWArray(1, i) <= 10 Then
SWArray1(1, k1) = SWArray(1, i)
SWArray1(2, k1) = 2035
SWArray1(3, k1) = 2005
SWArray1(4, k1) = 1005: k1 = k1 + 1
ElseIf SWArray(1, i) > 10 And SWArray(1, i) <= 12 Then
SWArray1(1, k1) = SWArray(1, i)
SWArray1(2, k1) = 2022
SWArray1(3, k1) = 1032
SWArray1(4, k1) = 4344: k1 = k1 + 1
End If
Else
'Stop
'use a different lagorithm (or not) and load SWArray2()
If SWArray(1, i) <= 10 Then
SWArray2(1, k2) = SWArray(1, i)
SWArray2(2, k2) = 2035
SWArray2(3, k2) = 2005
SWArray2(4, k2) = 1005: k1 = k1 + 1
ElseIf SWArray(1, i) > 10 And SWArray(1, i) <= 12 Then
SWArray2(1, k2) = SWArray(1, i)
SWArray2(2, k2) = 2022
SWArray2(3, k2) = 1032
SWArray2(4, k2) = 4344: k2 = k2 + 1
End If
End If
Next i
'drop the processed arrays content:
sh.Range("M1").Resize(k1 - 1, UBound(SWArray1, 2)).value = SWArray1
sh.Range("X1").Resize(k2 - 1, UBound(SWArray1, 2)).value = SWArray2
End Sub
The code can easily be adapted to return in different sheets.
It is not tested (no time to build the sheet environment...), but this should be the concept. If something goes wrong, please specify what error on what code line.
Now I need to go out. Please, examine the about supposed solution and send some feedback. If my assumption is not a correct one, please better define your need and I will try helping when I will be back.
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.
Problem
How can you horizontally align values in separate columns, and apply a dynamic formula? Preemptive thank you for any help or clues! The code pasted below works, in so far as it reaches halfway to the end destination. But how to accomplish the last two objectives?
1) Sum each range
2) Align the ranges horizontally
A sample sheet containing customer id, item and prices. Sales from Monday on the left, Tuesday on the right.
Current results
Desired results
Align cust id on rows A and E, with an associated sum. Notice how each yellow line contains cust id for identification, as well as associated Sum total.
Existing VBA Code
Sub AlignAndMatch()
'backup sheet
ActiveSheet.Copy after:=Sheets(Sheets.Count)
'Insert rows where current cell <> cell above
Dim i, totalrows As Integer
Dim strRange As String
Dim strRange2 As String
'----------------------------------------
'Monday sort table
Range("A2:C65536").Select
Selection.Sort Key1:=Range("A2:C65536"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Monday insert loop
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
strRange = "A" & i
strRange2 = "A" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Range(Cells(i + 1, 1), Cells(i + 2, 3)).Insert xlDown 'think cells ~A1:C2 insert
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = i + 2 'for insert 2 rows
End If
Loop
'Monday footer row loop
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
If IsEmpty(Range("A" & i).Value) And Not IsEmpty(Range("A" & i + 1).Value) Then
Range("A" & i).Value = Range("A" & i + 1).Value
Range("B" & i).Value = "Sum"
End If
Loop
'----------------------------------------
'Tuesday sort table
Range("E2:G65536").Select
Selection.Sort Key1:=Range("E2:G65536"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Tuesday insert loop
totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
strRange = "E" & i
strRange2 = "E" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Range(Cells(i + 1, 5), Cells(i + 2, 7)).Insert xlDown 'think cells ~A1:C2 insert
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = i + 2 'for insert 2 rows
End If
Loop
'Tuesday footer row loop
totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
If IsEmpty(Range("E" & i).Value) And Not IsEmpty(Range("E" & i + 1).Value) Then
Range("E" & i).Value = Range("E" & i + 1).Value
Range("F" & i).Value = "Sum"
End If
Loop
End Sub
If I needed something like that I might think twice what I want and why: if the original day lists don't come from somehwere, you could put everything into one list and make some pivots...
But. Here's some idea, playing with the arrays again and there's probably work to do, but does this help:
Option Base 1
Sub ReLists()
Dim ListSheet As Worksheet
Dim DayCorners() As Range
Dim Day()
Dim Days As Integer
Dim CustIDs()
Dim CustomerRow() 'for placement in the final list
Dim DayList()
Dim MaxCustIDs As Integer
Dim NewCustID As Boolean
Days = 2
MaxCustIDs = 5
ReDim DayCorners(Days)
ReDim Day(Days)
ReDim CustomerRow(MaxCustIDs + 2)
CustomerRow(1) = 0
ReDim CustIDs(MaxCustIDs)
ReDim DayItems(1, 1)
Set ListSheet = Worksheets("Sheet1")
Set DayCorners(1) = ListSheet.Range("A2")
Set DayCorners(2) = ListSheet.Range("E2")
For d = 1 To Days
With ListSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=DayCorners(d)
.SetRange Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Day(d) = Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2))
If UBound(Day(d), 1) > UBound(DayItems, 2) Then
ReDim DayItems(Days, UBound(Day(d)))
End If
Next d
CustIDCount = 0
For d = 1 To Days
For r = 1 To UBound(Day(d), 1)
NewCustID = True
For u = 1 To UBound(CustIDs)
If CustIDs(u) = Day(d)(r, 1) Then NewCustID = False
Next u
If NewCustID Then
CustIDCount = CustIDCount + 1
CustIDs(CustIDCount) = Day(d)(r, 1)
End If
Next r
Next d
With Worksheets.Add(After:=Worksheets(ListSheet.Index))
Set DayCorners(1) = .Range("A2")
Set DayCorners(2) = .Range("E2")
End With
ReDim DayList(Days, CustIDCount, 100, 3)
For d = 1 To Days
For c = 1 To CustIDCount
rc = 1
For r = 1 To UBound(Day(d), 1)
If Day(d)(r, 1) = CustIDs(c) Then
DayList(d, c, rc, 1) = Day(d)(r, 1)
DayList(d, c, rc, 2) = Day(d)(r, 2)
DayList(d, c, rc, 3) = Day(d)(r, 3)
rc = rc + 1
End If
Next r
If CustomerRow(c) + rc + 2 > CustomerRow(c + 1) Then
CustomerRow(c + 1) = CustomerRow(c) + rc + 1
End If
Next c
If CustomerRow(c - 1) + rc + 2 > CustomerRow(c) Then
CustomerRow(c) = CustomerRow(c) + rc
End If
Next d
For d = 1 To Days
With DayCorners(d).Offset(-1, 0).Range("A1:C1")
.Value = Array("cust id", "item", "Price")
'formatting
End With
For c = 1 To CustIDCount
SumFormula = "=SUM(R[1]C:R[" & (CustomerRow(c + 1) - CustomerRow(c) - 1) & "]C)"
With DayCorners(d).Offset(CustomerRow(c), 0).Range("A1:D1")
If Not IsEmpty(DayList(d, c, 1, 1)) Then
.Value = Array(CustIDs(c), "Sum", SumFormula, "")
End If
.Interior.Color = 65535
End With
For rc = 1 To UBound(Day(d), 1)
If IsEmpty(DayList(d, c, rc, 1)) Then Exit For
DayCorners(d).Offset(CustomerRow(c) + rc, 0) = DayList(d, c, rc, 1)
DayCorners(d).Offset(CustomerRow(c) + rc, 1) = DayList(d, c, rc, 2)
DayCorners(d).Offset(CustomerRow(c) + rc, 2) = DayList(d, c, rc, 3)
Next rc
Next c
Next d
End Sub
I believe the solution is to simulate an SQL full outer join, via VBA. I'll start hacking away at it. Should be a fun personal challenge. I'll try to update this answer once I find the final solution.
The direction I'm following is here.
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