I have long searched for a way to match 2 arrays based on several conditions and then write a value to that array after those conditions are met. I HAVE done so, BUT it is far to slow and crashes Excel. I am trying to use the dictionary object to achieve this in an effort to speed up my matching procedure but I am failing miserably.
Simply put, in the below procedure, I am checking if certain conditions are true. If so then then write to OutPut_Array so that I can match the value found in the ShtInPut_Array later.
Sub Cat_Payments_Test2()
Dim InPut_Array As Variant, ShtInPut_Array As Variant
Dim OutPut_Array()
Dim i As Long
Dim x As Long, y As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Would have used Value 2, but I want to preseve the Date formating
InPut_Array = Sheet19.Range("A1:NWH26").Value
ShtInPut_Array = Sheet14.Range("A2:Z50667").Value
ReDim OutPut_Array(1 To 3, LBound(InPut_Array, 2) To UBound(InPut_Array, 2))
'The Part is super fast
'On Error Resume Next
For i = LBound(InPut_Array, 2) To UBound(InPut_Array, 2)
'Case 1: InPut_Array(14, i) is on the first day of the month
If InPut_Array(15, i) = (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) Then
'Looking for payments On First Day of CurrMonth
If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) Or InStr(InPut_Array(16, i), "Reclas") _
Or InStr(InPut_Array(16, i), "*Req Adj*")) And Not (InStr(InPut_Array(16, i), "Prior")) Then
InPut_Array(25, i) = "Payment"
InPut_Array(26, i) = "Repair Order"
ElseIf Len(InPut_Array(20, i)) = 7 And IsNumeric(InPut_Array(20, i)) And (InStr(InPut_Array(15, i), "Prior") _
Or InStr(InPut_Array(15, i), "Current")) And InPut_Array(19, i) < 0 Then
InPut_Array(24, i) = "RO/Accr Adj."
InPut_Array(25, i) = "Reversing Entry"
End If
'Case 2 : InPut_Array(14, i) is between the first day of the month and the last day of the month
ElseIf (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) < InPut_Array(14, i) < WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
'Looking for payments MidMonth (i.e. after the FirstDay_CurrMon _
but before LastDayCurrMont
If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) _
Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) And Not (InStr(InPut_Array(16, i), "Prior")) Then
InPut_Array(25, i) = "Payment"
InPut_Array(26, i) = "Repair Order"
'Write PO Num
OutPut_Array(1, i) = InPut_Array(21, i)
'Print the first day of the current month's date
OutPut_Array(2, i) = DatePart("d", (CDate(InPut_Array(15, i)) - Day(CDate(InPut_Array(15, i))) + 1))
'Print the Amount
OutPut_Array(3, i) = Abs(InPut_Array(20, i))
End If
'Case 3.1 and 3.2
ElseIf InPut_Array(15, i) = WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
And (InStr(InPut_Array(16, i), "Prior") Or InStr(InPut_Array(16, i), "Current")) _
And InPut_Array(20, i) < 0 Then
InPut_Array(25, i) = "RO/Accr Adj."
InPut_Array(26, i) = "Repair Order"
'Write PO Num
OutPut_Array(1, i) = InPut_Array(21, i)
'Print the first day of the current month's date
OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
'Print Amount
OutPut_Array(3, i) = Abs(InPut_Array(20, i))
'If criteria met for payment on the last day of the Current Month _
then do the same as payments for MidMonth
ElseIf Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) _
Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
And Not (InStr(InPut_Array(16, i), "Prior")) Then
InPut_Array(25, i) = "Payment"
InPut_Array(26, i) = "Repair Order"
'PO Num
OutPut_Array(1, i) = InPut_Array(21, i)
'Print the first day of the current month's date
OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
'Print Amount
OutPut_Array(3, i) = Abs(InPut_Array(20, i))
End If
End If
Next i
'This matching procedure is what is crashing excel
For x = LBound(ShtInPut_Array, 1) To UBound(ShtInPut_Array, 1)
For y = LBound(OutPut_Array, 2) To UBound(OutPut_Array, 2)
If ShtInPut_Array(x, 21) = OutPut_Array(1, y) _
And DatePart("d", ShtInPut_Array(x, 15)) = OutPut_Array(2, y) _
And Abs(ShtInPut_Array(x, 20)) = OutPut_Array(3, y) Then
ShtInPut_Array(x, 25) = "RO/Accr Adj."
ShtInPut_Array(x, 26) = "Repair Order"
Exit For
End If
Next y
Next x
Sheet17.Range("A2").Resize(UBound(ShtInPut_Array, 1), UBound(ShtInPut_Array, 2)) = ShtInPut_Array
Application.EnableEvents = True
End Sub
I have been trying to figure this out for a good week or more, and if I told you how many test modules that I have now from skimming SO and literally everywhere else, you would think I am insane. My thoughts where to adapt #TimWilliams idea from This post, but I would need array indexes, not addresses. At this point I need some SO genius. Thanks to all those with ideas, or answers!
Edit: Below is the full working code with #TimWilliams Dictionary Implementation (many many thanks Tim). The only difference is, I choose to use early binding instead of late binding for the Dictionary Object. To do this, you must reference Microsoft Scripting Runtime in the Visual Basic Editor (VBE) by selecting Tools > References > Microsoft Scripting Runtime. Early binding adds a bit more speed because you are informing Excel about the object ahead of runtime. It also enables the VBE's intellisense feature, which is nice for quickly accessing the properties and methods of an object.
Sub Cat_Payments_Test2()
Dim InPut_Array As Variant, ShtInPut_Array As Variant
Dim OutPut_Array()
Dim i As Long
Dim x As Long, y As Long
Dim Dict As Dictionary 'Early Binding
Dim k As Variant
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Would have used Value 2, but I want to preseve the Date formating
InPut_Array = Sheet19.Range("A1:NWH26").Value
ShtInPut_Array = Sheet14.Range("A2:Z50667").Value
ReDim OutPut_Array(1 To 3, LBound(InPut_Array, 2) To UBound(InPut_Array, 2))
For i = LBound(InPut_Array, 2) To UBound(InPut_Array, 2)
'Case 1: GL/Date (i.e.InPut_Array(14, i)) is on the first day of the month
If InPut_Array(15, i) = (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) Then
'Looking for payments On First Day of CurrMonth
If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
And InPut_Array(20, i) > 0 And (InPut_Array(16, i) = InPut_Array(17, i) Or _
InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
And Not (InStr(InPut_Array(16, i), "Prior")) Then
InPut_Array(25, i) = "Payment"
InPut_Array(26, i) = "Repair Order"
ElseIf Len(InPut_Array(20, i)) = 7 And IsNumeric(InPut_Array(20, i)) _
And (InStr(InPut_Array(15, i), "Prior") Or InStr(InPut_Array(15, i), "Current")) _
And InPut_Array(19, i) < 0 Then
InPut_Array(24, i) = "RO/Accr Adj."
InPut_Array(25, i) = "Reversing Entry"
End If
'Case 2 : GL/Date is between the first day of the month and the last day of the month
ElseIf (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1) < InPut_Array(15, i) < WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
'Looking for payments MidMonth (i.e. after the FirstDay_CurrMon _
but before LastDayCurrMont
If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 _
And (InPut_Array(16, i) = InPut_Array(17, i) Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
And Not (InStr(InPut_Array(16, i), "Prior")) Then
InPut_Array(25, i) = "Payment"
InPut_Array(26, i) = "Repair Order"
'Write PO Num
OutPut_Array(1, i) = InPut_Array(21, i)
'Print the first day of the current month's date
OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
'Print the Amount
OutPut_Array(3, i) = Abs(InPut_Array(20, i))
End If
'Case 3.1 and 3.2: If GL/Date is on the last of the month
ElseIf InPut_Array(15, i) = WorksheetFunction.EoMonth(InPut_Array(15, i), 0) Then
If Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) _
And (InStr(InPut_Array(16, i), "Prior") Or InStr(InPut_Array(16, i), "Current")) _
And InPut_Array(20, i) < 0 Then
InPut_Array(25, i) = "RO/Accr Adj."
InPut_Array(26, i) = "Repair Order"
'Write PO Num
OutPut_Array(1, i) = InPut_Array(21, i)
'Print the first day of the current month's date
OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
'Print Amount
OutPut_Array(3, i) = Abs(InPut_Array(20, i))
'If criteria met for payment on the last day of the Current Month _
then do the same as payments for MidMonth
ElseIf Len(InPut_Array(21, i)) = 7 And IsNumeric(InPut_Array(21, i)) And InPut_Array(20, i) > 0 _
And (InPut_Array(16, i) = InPut_Array(17, i) Or InStr(InPut_Array(16, i), "Reclas") Or InStr(InPut_Array(16, i), "*Req Adj*")) _
And Not (InStr(InPut_Array(16, i), "Prior")) Then
InPut_Array(25, i) = "Payment"
InPut_Array(26, i) = "Repair Order"
'PO Num
OutPut_Array(1, i) = InPut_Array(21, i)
'Print the first day of the current month's date
OutPut_Array(2, i) = DatePart("d", (InPut_Array(15, i) - Day(InPut_Array(15, i)) + 1))
'Print Amount
OutPut_Array(3, i) = Abs(InPut_Array(20, i))
End If
End If
Next i
'***************************
'Dictionary Implementation
Set Dict = New Dictionary 'Early Binding
'populate dictionary with composite keys from output array
For y = LBound(OutPut_Array, 2) To UBound(OutPut_Array, 2)
k = Join(Array(OutPut_Array(1, y), _
OutPut_Array(2, y), _
OutPut_Array(3, y)), "~~")
Dict(k) = True
Next y
'compare...
For x = LBound(ShtInPut_Array, 1) To UBound(ShtInPut_Array, 1)
k = Join(Array(ShtInPut_Array(x, 21), _
DatePart("d", ShtInPut_Array(x, 15)), _
Abs(ShtInPut_Array(x, 20))), "~~")
If Dict.Exists(k) Then
ShtInPut_Array(x, 25) = "RO/Accr Adj."
ShtInPut_Array(x, 26) = "Repair Order"
End If
Next x
'***************************
Sheet17.Range("A2").Resize(UBound(ShtInPut_Array, 1), UBound(ShtInPut_Array, 2)) = ShtInPut_Array
'Note for those who were curious as _
to why I did't Set Application.ScreenUpdating = True _
It's b/c Excel does so automatically, so not doing so _
pro-grammatically saves a bit of speed
Application.EnableEvents = True
End Sub
Something like this:
Dim dict, k
Set dict = CreateObject("scripting.dictionary")
'populate dictionary with composite keys from output array
For y = LBound(OutPut_Array, 2) To UBound(OutPut_Array, 2)
k = Join(Array(OutPut_Array(1, y), _
OutPut_Array(2, y), _
OutPut_Array(3, y)), "~~")
dict(k) = True
Next y
'compare...
For x = LBound(ShtInPut_Array, 1) To UBound(ShtInPut_Array, 1)
k = Join(Array(ShtInPut_Array(x, 21), _
DatePart("d", ShtInPut_Array(x, 15)), _
Abs(ShtInPut_Array(x, 20))), "~~")
If dict.exists(k) Then
ShtInPut_Array(x, 25) = "RO/Accr Adj."
ShtInPut_Array(x, 26) = "Repair Order"
End If
Next x
You have a wonderful reason to switch to an object-oriented approach - it's time to manage the complexity of the code by creating chains of responsibility, simplification, and splitting into short independent functions.
Object decomposition of the task may look like this:
Public Sub Code_All_2_Units_Tests (Optional ByVal msg As Variant)
Var_Public_Clear _
to_ClipBoard (_
Array_walk (_
Array_Comments_delete (_
Split_by_vbrclf (_
in_Quotes_remove (_
Underscore_replace (_
Paste_from_clipboard (_
Settings)))))))
End sub
Do not immediately strive for the speed of the code and its quality. First the quality of the code, then the speed.
The object-oriented approach has many other advantages.
Related
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've been having some problems with storing some calculated values into an excel sheet in specific cells. The complete code is lengthy but I've posted it below. While running with the debugger what I've found is that it is failing when it tries to store this first value in the first step of the following for loop:
For i = 1 To 100
Cells(i, 1).Value = Cmatrix(i, 1)
Cells(i, 2).Value = Cmatrix(i, 2)
Next i
I've also tried it with ActiveSheet.Cells(i, 1).Value but I still just get a #VALUE! error during the first line of the for loop. I've also tried with and without the .Value
The Cmatrix is declared as a variant but I've also declared it as a double before just to see. It is an array from 1-100 and 1-2. I've even tried just setting it equal to 1 but the same problem arrises.
The overall code is rather lengthy but is here with the problem area being closer to the bottom:
Option Explicit
Public Function Test(check As Integer) As Integer
Dim Response As Integer
If check = 1 Then
Response = MsgBox("Boundary Condition 1 selected, is this correct (select No for boundary condition 2)?", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 1
Else
Test = 2
End If
ElseIf check = 2 Then
Response = MsgBox("Boundary Condition 2 selected, is this correct (select No for boundary condition 1)?", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 2
Else
Test = 1
End If
Else
Response = MsgBox("Incorrect Boundary Condition, select Yes for condition 1 and No for condition 2", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 1
Else
Test = 2
End If
End If
End Function
Public Sub Check2(x)
MsgBox ("Value given is outside data range, answer may not be correct, extrapolating from calculated polynomial")
End Sub
Public Function cubic(ByVal r As Range, x As Double, Optional check As Integer = 1) As Double
Dim data() As Double
Dim check1 As Integer
Dim Smatrix() As Double
Dim Tmatrix() As Double
Dim Xmatrix() As Double
Dim Amatrix() As Double
Dim Hmatrix() As Double
Dim Cmatrix(1 To 100, 1 To 2) As Variant
Dim m As Integer
Dim i As Integer, j As Integer
Dim step As Double
Dim chart As Range, c As Range
m = r.Rows.Count
ReDim data(1 To m, 2)
ReDim Smatrix(1 To m, 1 To m)
ReDim Tmatrix(1 To m, 4)
ReDim Xmatrix(1 To m)
ReDim Amatrix(1 To m - 1, 1 To 4)
ReDim Hmatrix(1 To m)
check1 = Test(check)
For i = 1 To m
data(i, 1) = r(i, 1).Value
data(i, 2) = r(i, 2).Value
Next i
Smatrix(1, 1) = 1
Smatrix(m, m) = 1
For i = 1 To m - 1
Hmatrix(i) = data(i + 1, 1) - data(i, 1)
Next i
If check1 = 2 Then
Smatrix(1, 2) = -1
Smatrix(m, m - 1) = -1
End If
For i = 2 To m - 1
Smatrix(i, i - 1) = Hmatrix(i - 1)
Smatrix(i, i + 1) = Hmatrix(i)
Smatrix(i, i) = 2 * (Hmatrix(i - 1) + Hmatrix(i))
Next i
For i = 2 To m - 1
Tmatrix(i, 4) = 6 * ((data(i + 1, 2) - data(i, 2)) / Hmatrix(i) - (data(i, 2) - data(i - 1, 2)) / Hmatrix(i - 1))
Next i
For i = 1 To m
If i <> 1 Then
Tmatrix(i, 1) = Smatrix(i, i - 1)
End If
Tmatrix(i, 2) = Smatrix(i, i)
If i <> m Then
Tmatrix(i, 3) = Smatrix(i, i + 1)
End If
Next i
For i = 2 To m
Tmatrix(i, 1) = Tmatrix(i, 1) / Tmatrix(i - 1, 2)
Tmatrix(i, 2) = Tmatrix(i, 2) - Tmatrix(i, 1) * Tmatrix(i - 1, 3)
Tmatrix(i, 4) = Tmatrix(i, 4) - Tmatrix(i, 1) * Tmatrix(i - 1, 4)
Next i
Xmatrix(m) = Tmatrix(m, 4) / Tmatrix(m, 2)
For i = m - 1 To 1 Step -1
Xmatrix(i) = (Tmatrix(i, 4) - Tmatrix(i, 3) * Xmatrix(i + 1)) / Tmatrix(i, 2)
Next i
For i = 1 To m - 1
Amatrix(i, 1) = (Xmatrix(i + 1) - Xmatrix(i)) / 6 * Hmatrix(i)
Amatrix(i, 2) = Xmatrix(i) / 2
Amatrix(i, 3) = (data(i + 1, 2) - data(i, 2)) / Hmatrix(i) - Hmatrix(i) * Xmatrix(i) / 2 - Hmatrix(i) * (Xmatrix(i + 1) - Xmatrix(i)) / 6
Amatrix(i, 4) = data(i, 2)
Next i
step = (data(m, 1) - data(1, 1)) / 100
For i = 0 To (m - 1)
Cmatrix(i + 1, 1) = data(1, 1) + i * step
Next i
For j = 1 To m
If Cmatrix(j, 1) = data(m, 1) Then
Cmatrix(j, 2) = data(m, 2)
Else
For i = 1 To m - 1
If data(i, 1) < Cmatrix(j, 1) And Cmatrix(j, 1) < data(i + 1, 1) Then
Cmatrix(j, 2) = Amatrix(i, 1) * (Cmatrix(j, 1) - data(i, 1)) ^ 3 + Amatrix(i, 2) * (Cmatrix(j, 1) - data(i, 1)) ^ 2 + Amatrix(i, 3) * (Cmatrix(j, 1) - data(i, 1)) + Amatrix(i, 4)
ElseIf Cmatrix(j, 1) = data(i, 1) Then
Cmatrix(j, 2) = data(i, 2)
End If
Next i
End If
Next j
If x < data(1, 1) Or x > data(m, 1) Then
Call Check2(x)
If x < data(1, 1) Then
cubic = Amatrix(1, 1) * (x - data(1, 1)) ^ 3 + Amatrix(1, 2) * (x - data(1, 1)) ^ 2 + Amatrix(1, 3) * (x - data(1, 1)) + Amatrix(1, 4)
ElseIf x > data(m, 1) Then
cubic = Amatrix(m - 1, 1) * (x - data(m - 1, 1)) ^ 3 + Amatrix(m - 1, 2) * (x - data(m - 1, 1)) ^ 2 + Amatrix(m - 1, 3) * (x - data(m - 1, 1)) + Amatrix(m - 1, 4)
End If
ElseIf x = data(m, 1) Then
cubic = data(m, 2)
Else
For i = 1 To m - 1
If data(i, 1) < x And x < data(i + 1, 1) Then
cubic = Amatrix(i, 1) * (x - data(i, 1)) ^ 3 + Amatrix(i, 2) * (x - data(i, 1)) ^ 2 + Amatrix(i, 3) * (x - data(i, 1)) + Amatrix(i, 4)
ElseIf x = data(i, 1) Then
cubic = data(i, 2)
End If
Next i
End If
For i = 1 To 100
Cells(i, 1).Value = Cmatrix(i, 1)
Cells(i, 2).Value = Cmatrix(i, 2)
Next i
Set chart = Range("A1:B100")
Dim cht As Object
Set cht = ActiveSheet.Shapes.AddChart2(XlChartType:=xlXYScatterSmooth)
cht.chart.SetSourceData Source:=chart
End Function
I want to alphabetically sort a 2-dimensional array results(lcol, 4) with VBA. This array contains 4 columns and variable number of rows, based on the values of the last column.
This is the code of how I populated the array :
ReDim results(lcol, 4)
For i = 1 To lcol
results(i, 1) = ThisWorkbook.Sheets(2).Range("B1").Offset(, i - 1).Value
results(i, 2) = "0"
results(i, 3) = ThisWorkbook.Sheets(3).Range("C2").Offset(i - 1, 0).Value
Next i
For Each of In ThisWorkbook.Sheets(1).Range("A1:C" & lrow2)
Set modele = of.Offset(, 1)
Set qte = of.Offset(, 2)
For Each modele2 In ThisWorkbook.Sheets(2).Range("A2:A481")
If modele2.Value = modele.Value Then
For i = 1 To lcol 'à modifier
results(i, 2) = results(i, 2) + qte.Value * modele2.Offset(, i).Value
If results(i, 2) <= results(i, 3) Then
results(i, 4) = "OK"
Else
results(i, 4) = "Rupture"
End If
Next i
Exit For
End If
Next modele2
Next of
This provides a basic (quiksort?) ascending sort on your populated array with the last column as the primary key.
dim i as long, j as long, tmp as variant
redim tmp(lbound(results, 1) to lbound(results, 1), lbound(results, 2) to ubound(results, 2))
for i = lbound(results, 1) to ubound(results, 1) - 1
if results(i, ubound(results, 2)) > results(i+1, ubound(results, 2)) or _
results(i, ubound(results, 2)) = vbnullstring then
for j = lbound(results, 2) to ubound(results, 2)
tmp(lbound(results, 1), j) = results(i, j)
next j
for j = lbound(results, 2) to ubound(results, 2)
results(i, j) = results(i+1, j)
next j
for j = lbound(results, 2) to ubound(results, 2)
results(i+1, j) = tmp(lbound(results, 1), j)
next j
end if
next i
Sorry for all the lbound and ubound but I had no idea if your array was zero-based of 1-based. The For i = 1 To lcol was not definitive. All evidence points to your arr being zero-based.
You could have SortedList object do the work
Assuming your results array is 1-based and with 4 columns, you could try the following code (UNTESTED):
Sub SortArray(results As Variant)
Dim i As Long, j As Long
With CreateObject("System.Collections.SortedList")
For i = 1 to UBound(results)
.Add results(i,4), Application.Index(result,i,0)
Next
For i = 1 To .Count
For j = 1 To 4
results(i, j) = .GetByIndex(i)(j)
Next
Next
End With
End Sub
Which you would call in your “main” sub as follows:
SortArray results
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