Disclaimer: My background as a programmer is limitted to 1 university course in C++, and hobbyist vb.net macro programming.
My goal is to be able to take a bunch of data from a BOM, sort it conditionally, and then return a simple list with the document names.
I've come across some good information on LINQ and iComparable for structures/strings but could use some further guidance in what I need to do to make this happen.
Essentially it will be a multi level sort with some logic like:
-> Put objects with 'Drawing' = True first.
-> Sort then by ComponentDefinition/Secondary document desciber;
(ie; assemblies and weldments, then plate, then structural steel, then hardware).
-> Sort Assemblies and weldments by Renamed vs Matl'l Spec then by weight
-> Sort Structural by type, then by size
-> Sort hardware by nomial size, then by type, then by thread unc/unf, then by length
-> Put the remainder last (ie; virtual components.
From what I've read, it seems like I can accomplish this by multiple sets of linq's if I can get it working,
Or I can use a Compare function and just compare each line in its entirety to the next (as my understand of it would suggest?)
So at the end of the day, I would want a list to spit out something like:
1) Drawing - Weldment - Named - Weight
2) Drawing - Assembly - Named - Weight
3) Drawing - Assembly - Unnamed - Weight
4) Drawing - Weldment - unnamed - weight
5) Drawing - Plate - 1" Thick x 48 sq in.
6) Drawing - Plate - 1" Thick x 36 sq in.
7) No Drawing - Plate - 1" Thick X 52 in
8) No Drawing - Plate - 1/2" thick X 52 in
9) No Drawing - 1/2" Bolt - UNC - 3"
10) No Drawing - 1/2" Bolt - UNC - 2"
11) No Drawing - 1/2" Nut - UNC
12) No Drawing - 1/2" Washer
13) No Drawing - 1/4" Bolt - UNC - 2"
14) No Drawing - Virtual Component
By using the Case 0 as the next level, and making a tree sort seems like the right way to do it, as long as I can get the basic tree working.
That way, I'm only sorting items based on how they ended up in the previous sort. (No need to go any further if I'm comparing an assembly to hardware as would be the secondary level of my sort after the Drawing/NoDrawing sort)
This is as far as I have gotten, and If I can figure out how to get this working, I'm thinking I'm likely set to go on from here
'Jagged Array Sorting with Tag Array
Sub Main()
Dim oBOMRowCount As Integer = 4
Dim oBOMFactorArray As Double(oBOMRowCount-1)(){}
oBOMFactorArray(0) = {"2", "5"}
oBOMFactorArray(1) = {"1", "5"}
oBOMFactorArray(2) = {"1", "2"}
oBOMFactorArray(3) = {"2", "7"}
Dim tagArray() As Integer = {0, 1, 2, 3}
' Initialize the comparer and sort
Dim myComparer As New RectangularComparer(oBOMFactorArray)
Array.Sort(tagArray, myComparer)
Dim i As Integer
For j = 0 To 3
oLine = ""
For i = 0 To 1
If oLine = ""
oLine = "oList[" & (oBOMFactorArray(j)(i)) & "]"
Else
oLine = oLine & "[" & (oBOMFactorArray(j)(i)) & "]"
End If
Next
oStr = oStr & vbLf & oLine
Next
MsgBox(oStr)
End Sub()
Class RectangularComparer
Implements IComparer
' maintain a reference to the 2-dimensional array being sorted
Private sortArray(,) As Integer
' constructor initializes the sortArray reference
Public Sub New(ByVal theArray(,) As Double)
sortArray = theArray
End Sub
Public Function Compare(ByVal x As Object, ByVal y As Object) As Integer Implements IComparer.Compare
' x and y are integer row numbers into the sortArray
Dim i1 As Integer = DirectCast(x, Integer)
Dim i2 As Integer = DirectCast(y, Integer)
Select Case sortArray(i1, 0).CompareTo(sortArray(i2, 0))
Case -1
Case 1
Case 0
Return sortArray(i1, 1).CompareTo(sortArray(i2, 1))
End Select
' compare the items in the sortArray
End Function
End Class
Related
So I have a data set that is made up of a variety tag numbers - I'm trying to develop a VBA "fucntion" to basically give recommendation on a tag number when inputting a new one. This would be easy but the current list gives gaps within tag numbers (eg) goes 4001 4002 4005 . This bit of code is taking that gap and storing "option" tags which I plan to display to the user (so 4003 and 4004). The problem is that these gaps are encountered more than once eg) 4001 4002 4005 4006 4007 4011 4012 and when it comes to the second gap (4008 4009 4010) it overwrites the existing array - how can I get it take each gap and then begin the array below that?
My code is as follows:
For j = 2 To UBound(strArrayNumber)
If strArrayNumber(j) <> strArrayNumber(j - 1) + 1 Then
Gap = strArrayNumber(j) - strArrayNumber(j - 1)
For b = 1 To Gap
ReDim TagOptions(1 To Gap) As Integer
TagOptions(b) = strArrayNumber(j - 1) + b
sh.Cells(b, 6) = TagOptions(b)
Next b
End If
At the prompting of #JohnSUN here is the bare bones of a solution using Scripting.Dictionary.
The OP desires to manage a data set. To simplify this management I have chosen to create a TagList object. The TagList object allows
Population of the tag list from two arrays
Updating the value associated with a tag item
getting back an array of tags or object
getting an array of the next free tags
testing if a tag exists
This is a bare bones example as it is designed to point the way rather than provide a complete solution. It has some obvious ommisions, i.e. there is no code for what happens if a the request for the next set of free tags uses a tag that is higher then the maximum tag number, there is no error code for what happens if we try to add an existing tag to the TagList etc.
The Class Taglist code compiles without error and shows no significant inospection results after a Rubberduck code inspection
Class TagList
Option Explicit
Private Type State
' Requires a reference to 'Microsoft Scripting Runtime'
TagList As Scripting.Dictionary
End Type
Private s As State
Private Sub Class_Initialize()
Set s.TagList = New Scripting.Dictionary
End Sub
Public Property Get Item(ByVal iptag As Long) As Variant
Item = s.TagList.Item(iptag)
End Property
Public Property Let Item(ByVal iptag As Long, ByVal ipitem As Variant)
s.TagList.Item(iptag) = ipitem
End Property
Public Function Tags() As Variant
Tags = s.TagList.keys
End Function
Public Function Items() As Variant
Items = s.TagList.Items
End Function
Public Sub Add(ByVal ipTags As Variant, Optional ByVal ipItems As Variant)
'ipTags and ipItems should be arrays of equal size
If IsMissing(ipItems) Then
ReDim ipItems(UBound(ipTags) - LBound(Tags) + 1)
End If
If (UBound(ipTags) - LBound(ipTags)) - (UBound(ipItems) - LBound(ipItems)) <> 0 Then
Err.Raise vbObjectError + 512, "Size Error", "Arrays are different sizes"
End If
Dim myItemsIndex As Long
myItemsIndex = LBound(ipItems)
Dim myTag As Variant
For Each myTag In ipTags
s.TagList.Add myTag, CVar(ipItems(myItemsIndex))
myItemsIndex = myItemsIndex + 1
Next
End Sub
Public Function Exists(ByVal iptag As Long) As Boolean
Exists = s.TagList.Exists(iptag)
End Function
Public Function NextFreeTags(ByVal iptag As Long) As Variant
If iptag < 1 Then
Err.Raise vbObjectError + 512, "Negative Tag", "Tag numbers must be positive"
End If
Dim myFreeTags As Scripting.Dictionary
Set myFreeTags = New Scripting.Dictionary
Do While s.TagList.Exists(iptag)
iptag = iptag + 1
Loop
Do Until s.TagList.Exists(iptag)
myFreeTags.Add iptag, iptag
iptag = iptag + 1
Loop
NextFreeTags = myFreeTags.keys
End Function
Thus we can now do the following
Dim myTagList as TagList
Set myTagList = New TagList
mytaglist.Add Array(4006, 4001, 4002, 4011, 4005, 4007)
' Note the above is the short form version we could equally say
' myTagList.add Array(4006, 4001, 4002, 4011, 4005, 4007), Array(Obj6, Obj1, Obj11, Obj5, Obj7)
'Oops, we forgot to add tag 4012
myTaglist.add array(4012)
' getting then next free tags
dim myTags as variant
myTags = myTaglist.NextFreeTags(4001)
etc
Let's not calculate the Gap. The parameters of the cycle by B can be any - we will use this. Try this:
Set oCell = sh.Range("F1")
TagOptions = Array()
For j = 2 To UBound(strArrayNumber)
If strArrayNumber(j) <> strArrayNumber(j - 1) + 1 Then
For b = strArrayNumber(j - 1) + 1 To strArrayNumber(j) - 1
uBoundTagOptions = UBound(TagOptions) + 1
ReDim Preserve TagOptions(1 To uBoundTagOptions)
TagOptions(uBoundTagOptions) = b
oCell.Value = b
Set oCell = oCell.Offset(1, 0)
Next b
End If
Next j
Don't forget to specify Option Base 1 at the beginning of the module, otherwise TagOptions = Array() will create an empty array [0..-1] , with LBound = 0, but you want from LBound = 1
UPDATE
By the way, there is one old trick using an auxiliary array. This is used to clear data from duplicates, for sorting and other things. The method is resource-intensive, but very fast. It looks something like this:
Function getGaps(aData As Variant) As Variant
Dim lB As Long, uB As Long, i As Long, lCount As Long
Dim aTemp() As Boolean, aResult() As Long
If IsArray(aData) Then
lB = Application.WorksheetFunction.Min(aData)
uB = Application.WorksheetFunction.Max(aData)
Rem Let's create an auxiliary array of boolean flags. It may be very large, but it won't be long.
ReDim aTemp(lB To uB)
Rem Let's mark in the array those values ??that are in the aData.
Rem In this case, we will skip duplicates, if any, and count the number of unique numbers.
lCount = 0
For i = LBound(aData) To UBound(aData)
If Not aTemp(aData(i)) Then
aTemp(aData(i)) = True
lCount = lCount + 1
End If
Next i
Rem Number of values in gaps:
uB = uB - lB - lCount + 1
If uB > 0 Then ' It may be that there were no gaps in the array
ReDim aResult(1 To uB)
lCount = 0
For i = LBound(aTemp) To UBound(aTemp)
If Not aTemp(i) Then
lCount = lCount + 1
aResult(lCount) = i
End If
Next i
Rem Here it is - the result of the function
getGaps = aResult
Rem The interpreter will destroy this variable immediately after exiting the function,
Rem but will free the memory a little later. This line should help free memory faster
ReDim aTemp(0)
End If
End If
Rem In all other cases, the function will return Empty
End Function
Despite the number of lines, it is very simple and very fast since all the work is done in RAM.
With this function, all the code you showed in your question becomes:
Set oCell = sh.Range("F1")
oCell.EntireColumn.ClearContents ' This is for the case where no gaps are found
TagOptions = getGaps(strArrayNumber)
If IsEmpty(TagOptions) Then
Debug.Print "No gaps in array"
Exit Sub
End If
oCell.Resize(UBound(TagOptions), 1).Value2 = Application.WorksheetFunction.Transpose(TagOptions)
Of course TRANSPOSE () might not work correctly for a very large array. But I hope that you are not so cruel to your users and the list of possible tags does not exceed a hundred or two.
I have this textfile:
Paul George|2.87|29
Stephen Curry|2.85|28
Jamal Murray|2.72|21
PJ Tucker|2.72|11
Kyle Lowry|2.61|15
Game
Paul George|g2d|g2p
Stephen Curry|g2d|g2p
Jamal Murray|g2d|g2p
PJ Tucker|g2d|g2p
Kyle Lowry|g2d|g2p
Game
Paul George|g3d|g3p
Stephen Curry|g3d|g3p
Jamal Murray|g3d|g3p
PJ Tucker|g3d|g3p
Kyle Lowry|g3d|g3p
Game
Paul George|g4d|g4p
Stephen Curry|g4d|g4p
Jamal Murray|g4d|g4p
PJ Tucker|g4d|g4p
Kyle Lowry|g4d|g4p
I want to add the items to the arrays
Names(name, gamenumber)
Distance(distance, gamenumber)
Points(Points, gamenumber)
with the first index being the data for the player, and the second being the game that data is from
For example,
distance(1, 0) = 2.87
distance(5, 0) = 2.61
distance(1, 1) = g2d
So that the indexes match up with the player for the given game number.
So far I have:
Private Sub openFile_Click(sender As Object, e As EventArgs) Handles openFile.Click
OpenFileDialog.ShowDialog()
Dim strFileName = OpenFileDialog.FileName
Dim objReader As New System.IO.StreamReader(strFileName)
Dim textline As String
Dim Names(100, 3) As String
Dim Distance(100, 3) As String
Dim Points(100, 3) As String
Dim Count As Integer = 0
Dim GameNumber As Integer = 0
Do While objReader.Peek() <> -1
textline = objReader.ReadLine() & vbNewLine
If textline = "Game" Then
GameNumber = GameNumber + 1
Else
Dim parts() As String = textline.Split("|")
Names(Count, GameNumber) = parts(0)
Distance(Count, GameNumber) = parts(1)
Points(Count, GameNumber) = parts(2)
Count = Count + 1
End If
Loop
End Sub
The parts of each line are split up by |, putting them into "parts", it then assigns the three parts it gets from the line (the player name, distance, and points) into there separate arrays as
Names(<Name>, 0)
Distance(<Distance>, 0)
Points(<Points>, 0)
It continues down the textfile but IF the line = "Game" it should, increment GameNumber, and then move to the next line, continuing to add the data, instead as
Names(<Name>, 1)
Distance(<Distance>, 1)
Points(<Points>, 1)
and so on, but it my code isn't working. After getting this working, I wont it to print the desired Game statistics for the players on the page in a listbox with something like:
For n = 0 To Count - 1
lstNames.Items.Add(Names(n, GameWanted))
lstNames.Items.Add(" ")
lstDistance.Items.Add(Distance(n, GameWanted) + " Miles")
lstDistance.Items.Add(" ")
lstPoints.Items.Add(Points(n, GameWanted))
lstPoints.Items.Add(" ")
Next
This would become a lot easier if you create a class representing your player and index them with a dictionary
Class Player
Public Property Distances as List(Of Decimal)
Public Property Points as List(Of Integer)
Public Property Name as String
Public Sub New(n as String)
Name = n
Distances = New List(of Decimal)
Points = New List(of Integer)
End sub
End class
And then in your method that reads your file:
Dim d as new Dictionary(of String, Person)
ForEach line as String in File.ReadAllLines(...)
Dim bits = line.Split("|"c)
If bits.Length < 3 Then Continue For
If Not d.ContainsKey Then d.Add(bits(0), New Person(bits(0))
Dim p = d(bits(0)) 'retrieve the old or just added person
p.Distances.Add(decimal.parse(bits(1)))
p.Points.Add(integer.parse(bits(2)))
Next line
Note; I'm a c# programmer and seldom do vb any more. I code with array indexes starting at 0, if you're on 1 base indexing, add one to the indexes above. This code should probably be treated as pseudocode; it was written on a cellphone from a 5 year old memory of what vb looks like and might have a raft of vb syntax errors(sorry) or take the long way round to do things that we have shorter sybtaxes for these days (list initializers etc)
At the end of this loop through all the file you will have a dictionary of your people, one per name encountered. Each person will have a list of scores and distances. If you want to add them up or average them add a Function to person class that iterates the list and returns the result, and to print them all out do a
foreach s as string in d.Keys
Console.Write(d(s).Name & " got avg distance " & d(s).GetAverageDist())
Or similar
To print out all their distances:
foreach s as string in d.Keys
foreach dis as decimal in d(s).Distances
Console.Write(d(s).Name & " got distance " & dis)
This is object oriented programming; we model the world using classes to represent things and do useful stuff. We don't try to collect data together in 20 different arrays and tie it all together with indexes etc - that's a very procedural code mindset and the opposite of what vb.net was invented for
It's likely actually that this falls short of a proper solution and is also somewhat hypocritical because I use two lists to track distance and points and assert that the list indexes are equal - the distance at index 3 and the points at index 3 are from game 4 (zero based indexing note)
What we really should do is also define a GameResult class and it have properties of distance, points and gamenumber, then each person class has a single List(of GameResult) - person could have a function that returns a nicely formatted score card for that person - that's proper OO :)
I was wondering if there was any way to change the number of dimensions of an array:
In VBA,
Depending on an integer max_dim_bound which indicates the the
desired nr. of dimensions.
Allowing for a starting index of the dimension: E.G. `array(4 to 5, 3 to 6) where the number of 3 to 6 are variable integers.
*In the code itself without extra tools
*Without exporting the code.
To be clear, the following change does not change the nr of dimensions of an array, (merely the starting end ending indices of the elements in each respective dimension):
my_arr(3 to 5, 6 to 10)
'changed to:
my_arr(4 to 8, 2 to 7)
The following example would be a successfull change of the nr. of dimensions in an array:
my_arr(3 to 5, 6 to 10)
'changed to:
my_arr(4 to 8, 2 to 7,42 to 29)
This would also be a change in the nr. of dimensions in an array:
my_arr(4 to 8, 2 to 7,42 to 29)
'changed to:
my_arr(3 to 5, 6 to 10)
So far my attempts have consisted of:
Sub test_if_dynamically_can_set_dimensions()
Dim changing_dimension() As Double
Dim dimension_string_attempt_0 As String
Dim dimension_string_attempt_1 As String
Dim max_dim_bound As String
Dim lower_element_boundary As Integer
Dim upper_element_boundary As Integer
upper_element_boundary = 2
max_dim_bound = 4
For dimen = 1 To max_dim_bound
If dimen < max_dim_bound Then
dimension_string_attempt_0 = dimension_string_attempt_0 & "1 To " & upper_element_boundary & ","
MsgBox (dimension_string_attempt_0)
Else
dimension_string_attempt_0 = dimension_string_attempt_0 & "1 To " & upper_element_boundary
End If
Next dimen
MsgBox (dimension_string_attempt_0)
'ReDim changing_dimension(dimension_string_attempt_0) 'does not work because the "To" as expected in the array dimension is not a string but reserved word that assists in the operation of setting an array's dimension(s)
'ReDim changing_dimension(1 & "To" & 3, 1 To 3, 1 To 3) 'does not work because the word "To" that is expected here in the array dimension is not a string but a reserved word that assists the operation of setting an array's dimension(s).
'ReDim changing_dimension(1 To 3, 1 To 3, 1 To 3, 1 To 3)
'attempt 1:
For dimen = 1 To max_dim_bound
If dimen < max_dim_bound Then
dimension_string_attempt_1 = dimension_string_attempt_1 & upper_element_boundary & ","
MsgBox (dimension_string_attempt_1)
Else
dimension_string_attempt_1 = dimension_string_attempt_1 & upper_element_boundary
End If
Next dimen
MsgBox (dimension_string_attempt_1)
ReDim changing_dimension(dimension_string_attempt_1) 'this does not change the nr of dimensions to 2, but just one dimension of "3" and "3" = "33" = 33 elements + the 0th element
'changing_dimension(2, 1, 2, 1) = 4.5
'MsgBox (changing_dimension(2, 1, 2, 1))
End Sub
*Otherwise a solution is to:
Export the whole code of a module, and at the line of the dimension substitute the static redimension of the array, with the quasi-dynamic string dimension_string.
Delete the current module
Import the new module with the quasi-dynamic string dimension_string as a refreshed static redimension in the code.
However, it seems convoluted and I am curious if someone knows a simpler solution.
Note that this is not a duplicate of: Dynamically Dimensioning A VBA Array? Even though the question seems to mean what I am asking here, the intention of the question seems to be to change the nr. of elements in a dimension, not the nr. of dimensions. (The difference is discussed in this article by Microsoft.)
In an attempt to apply the answer of Uri Goren, I analyzed every line and looked up what they did, and commented my understanding behind it, so that my understanding can be improved or corrected. Because I had difficulty not only running the code, but also understanding how this answers the question. This attempt consisted of the following steps:
Right click the code folder ->Insert ->Class Module Then clicked:
Tools>Options> "marked:Require variable declaration" as shown
here at 00:59.
Next I renamed the class module to
Next I wrote the following code in class module FlexibleArray:
Option Explicit
Dim A As New FlexibleArray
Private keys() As Integer
Private vals() As String
Private i As Integer
Public Sub Init(ByVal n As Integer)
ReDim keys(n) 'changes the starting element index of array keys to 0 and index of last element to n
ReDim vals(n) 'changes the starting element index of array keys to 0 and index of last element to n
For i = 1 To n
keys(i) = i 'fills the array keys as with integers from 1 to n
Next i
End Sub
Public Function GetByKey(ByVal key As Integer) As String
GetByKey = vals(Application.Match(key, keys, False))
' Application.Match("what you want to find as variant", "where you can find it as variant", defines the combination of match type required and accompanying output)
'Source: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/worksheetfunction-match-method-excel
' If match_type is 1, MATCH finds the largest value that is less than or equal to lookup_value. Lookup_array must be placed in ascending order: ...-2, -1, 0, 1, 2, ..., A-Z, FALSE, TRUE.
' If match_type is 0, MATCH finds the first value that is exactly equal to lookup_value. Lookup_array can be in any order.
' If match_type is -1, MATCH finds the smallest value that is greater than or equal to lookup_value. Lookup_array must be placed in descending order: TRUE, FALSE, Z-A, ...2, 1, 0, -1, -2, ..., and so on.
'so with False as 3rd optional argument "-1" it finds the smallest value greater than or equal to the lookup variant, meaning:
'the lowest value of keys that equals or is greater than key is entered into vals,
'with keys as an array of 1 to n, it will return key, if n >= key. (if keys is initialized right before getbykey is called and is not changed inbetween.
'vals becomes the number inside a string. So vals becomes the number key if key >= n.
End Function
Public Sub SetByKey(ByVal key As Integer, ByVal val As String)
vals(Application.Match(key, keys, False)) = val
'here string array vals(element index: key) becomes string val if key >=n (meaning if the element exists)
End Sub
Public Sub RenameKey(ByVal oldName As Integer, ByVal newName As Integer)
keys(Application.Match(oldName, keys, False)) = newName
'here keys element oldname becomes new name if it exists in keys.
End Sub
And then I created a new module11 and copied the code below in it, including modifications to try and get the code working.
Option Explicit
Sub use_class_module()
Dim A As New FlexibleArray 'this dimensions object A but it is not set yet
A.Init (3) 'calls the public sub "Init" in class module FlexibleArray, and passes integer n = 3.
'A.SetByKey(1, "a") 'this means that Objecgt A. in class FlexibleArray function SetByKey sets the private string array vals(1) in class Flexible Array becomes "a"
'A.SetByKey(2, "b") 'this means that Objecgt A. in class FlexibleArray function SetByKey sets the private string array vals(2) in class Flexible Array becomes "b"
'A.SetByKey(3, "c") 'this means that Object A. in class FlexibleArray function SetByKey sets the private string array vals(3) in class Flexible Array becomes "c"
'A.RenameKey(3,5) 'This means that object A in class FlexibleArray keys element 3 becomes 5 so keys(3) = 5
' Would print the char "c"
'to try to use the functions:
'A.SetByKey(1, "a") = 4
'MsgBox (keys("a"))
'test = A.SetByKey(1, "a") 'this means that Objecgt A. in class FlexibleArray function SetByKey sets the private string array vals(1) in class Flexible Array becomes "a"
'MsgBox (test)
'test_rename = A.RenameKey(3, 5) 'This means that object A in class FlexibleArray keys element 3 becomes 5 so keys(3) = 5
'MsgBox (test_rename)
'Print A.GetByKey(5) 'Method not valid without suitable object
'current problem:
'the A.SetByKey expects a function or variable, even though it appears to be a function itself.
End Sub
What I currently expect that this code replaces the my_array(3 to 4,5 to 9..) to an array that exists in/as the class module FlexibleArray, that is called when it needs to be used in the module. But Any clearifications would be greatly appreciated! :)
If the goal of redimensioning arrays is limited to a non-absurd number of levels, a simple function might work for you, say for 1 to 4 dimensions?
You could pass the a string representing the lower and upper bounds of each dimension and that pass back the redimensioned array
Public Function FlexibleArray(strDimensions As String) As Variant
' strDimensions = numeric dimensions of new array
' eg. "1,5,3,6,2,10" creates ARRAY(1 To 5, 3 To 6, 2 To 10)
Dim arr() As Variant
Dim varDim As Variant
Dim intDim As Integer
varDim = Split(strDimensions, ",")
intDim = (UBound(varDim) + 1) / 2
Select Case intDim
Case 1
ReDim arr(varDim(0) To varDim(1))
Case 2
ReDim arr(varDim(0) To varDim(1), varDim(2) To varDim(3))
Case 3
ReDim arr(varDim(0) To varDim(1), varDim(2) To varDim(3), varDim(4) To varDim(5))
Case 4
ReDim arr(varDim(0) To varDim(1), varDim(2) To varDim(3), varDim(4) To varDim(5), varDim(6) To varDim(7))
End Select
' Return re-dimensioned array
FlexibleArray = arr
End Function
Test it by calling it with your array bounds
Public Sub redimarray()
Dim NewArray() As Variant
NewArray = FlexibleArray("1,2,3,8,2,9")
End Sub
Should come back with an array looking like this in Debug mode
EDIT - Added Example of truly dynamic array of variant arrays
Here's an example of a way to get a truly flexible redimensioned array, but I'm not sure it's what you're looking for as the firt index is used to access the other array elements.
Public Function FlexArray(strDimensions As String) As Variant
Dim arrTemp As Variant
Dim varTemp As Variant
Dim varDim As Variant
Dim intNumDim As Integer
Dim iDim As Integer
Dim iArr As Integer
varDim = Split(strDimensions, ",")
intNumDim = (UBound(varDim) + 1) / 2
' Setup redimensioned source array
ReDim arrTemp(intNumDim)
iArr = 0
For iDim = LBound(varDim) To UBound(varDim) Step 2
ReDim varTemp(varDim(iDim) To varDim(iDim + 1))
arrTemp(iArr) = varTemp
iArr = iArr + 1
Next iDim
FlexArray = arrTemp
End Function
And if you look at it in Debug, you'll note the redimensioned sub arrays that are now accessible from the first index of the returned array
Sounds like you are abusing arrays for something they weren't meant to do with a ton of memory copying.
What you want is to write your own Class (Right click the code folder ->Insert ->Class Module), let's call it FlexibleArray.
Your class code would be something like this:
Private keys() as Integer
Private vals() as String
Private i as Integer
Public Sub Init(ByVal n as Integer)
Redim keys(n)
Redim vals(n)
For i = 1 to n
keys(i) = i
Next i
End Sub
Public Function GetByKey(ByVal key As Integer) As String
GetByKey = vals(Application.Match(key, keys, False))
End Function
Public Sub SetByKey(ByVal key As Integer, ByVal val As String)
vals(Application.Match(key, keys, False)) = val
End Sub
Public Sub RenameKey(ByVal oldName As Integer, ByVal newName As Integer)
keys(Application.Match(oldName, keys, False))=newName
End Sub
Now you can rename whatever key you want:
Dim A as New FlexibleArray
A.Init(3)
A.SetByKey(1, "a")
A.SetByKey(2, "b")
A.SetByKey(3, "c")
A.RenameKey(3,5)
Print A.GetByKey(5)
' Would print the char "c"
Extending it to integer ranges (like your example) is pretty straight forward
Sub FWP()
Dim i As Integer
Dim j As Integer
Dim n As Integer
n = Range("A1").Value
For i = 1 To n
For j = 1 To n
If Cells(i + 1, j) = 0 Then
Cells(i + 1, j).Value = Int(((n ^ 2) - 1 + 1) * Rnd + 1)
ElseIf Cells(i + 1, j) <> 0 Then
Cells(i + 1, j).Value = Cells(i + 1, j).Value
End If
Next j
Next i
I am trying to do a part of a homework question that asks to fill in missing spaces in a magic square in VBA. It is set up as a (n x n) matrix with n^2 numbers in; the spaces I need to fill are represented by zeros in the matrix. So far I have some code that goes through checking each individual cell value, and will leave the values alone if not 0, and if the value is 0, it replaces them with a random number between 1 and n^2. The issue is that obviously I'm getting some duplicate values, which isn't allowed, there must be only 1 of each number.
How do I code it so that there will be no duplicate numbers appearing in the grid?
I am attempting to put in a check function to see if they are already in the grid but am not sure how to do it
Thanks
There are a lot of approaches you can take, but #CMArg is right in saying that an array or dictionary is a good way of ensuring that you don't have duplicates.
What you want to avoid is a scenario where each cell takes progressively longer to populate. It isn't a problem for a very small square (e.g. 10x10), but very large squares can get ugly. (If your range is 1-100, and all numbers except 31 are already in the table, it's going to take a long time--100 guesses on average, right?--to pull the one unused number. If the range is 1-40000 (200x200), it will take 40000 guesses to fill the last cell.)
So instead of keeping a list of numbers that have already been used, think about how you can effectively go through and "cross-off" the already used numbers, so that each new cell takes exactly 1 "guess" to populate.
Here's one way you might implement it:
Class: SingleRandoms
Option Explicit
Private mUnusedValues As Scripting.Dictionary
Private mUsedValues As Scripting.Dictionary
Private Sub Class_Initialize()
Set mUnusedValues = New Scripting.Dictionary
Set mUsedValues = New Scripting.Dictionary
End Sub
Public Sub GenerateRange(minimumNumber As Long, maximumNumber As Long)
Dim i As Long
With mUnusedValues
.RemoveAll
For i = minimumNumber To maximumNumber
.Add i, i
Next
End With
End Sub
Public Function GetRandom() As Long
Dim i As Long, keyID As Long
Randomize timer
With mUnusedValues
i = .Count
keyID = Int(Rnd * i)
GetRandom = .Keys(keyID)
.Remove GetRandom
End With
mUsedValues.Add GetRandom, GetRandom
End Function
Public Property Get AvailableValues() As Scripting.Dictionary
Set AvailableValues = mUnusedValues
End Property
Public Property Get UsedValues() As Scripting.Dictionary
Set UsedValues = mUsedValues
End Property
Example of the class in action:
Public Sub getRandoms()
Dim r As SingleRandoms
Set r = New SingleRandoms
With r
.GenerateRange 1, 100
Do Until .AvailableValues.Count = 0
Debug.Print .GetRandom()
Loop
End With
End Sub
Using a collection would actually be more memory efficient and faster than using a dictionary, but the dictionary makes it easier to validate that it's doing what it's supposed to do (since you can use .Exists, etc.).
Nobody is going to do your homework for you. You would only be cheating yourself. Shame on them if they do.
I'm not sure how picky your teacher is, but there are many ways to solve this.
You can put the values of the matrix into an array.
Check if a zero value element exists, if not, break.
Then obtain your potential random number for insertion.
Iterate through the array with a for loop checking each element for this value. If it is not present, replace the zero element.
I'm trying to save a file but as a random name from a small list. This is what I have so far:
Option Explicit
Option Base 1
Public Sub SaveToDrive()
Dim categorys(5) As String
categorys(1) = "Adam"
categorys(2) = "James"
categorys(3) = "Henry"
categorys(4) = "William"
categorys(5) = "Keith"
ThisWorkbook.SaveAs Filename:="e:\" & categorys(Int((5 - 1 + 1) * Rnd + 1)).Name
End Sub
Currently, this returns an Invalid Qualifier error on "categorys" in the second to last line.
I'm completely new to VBA, but I was wondering if this was possible or if there was another/better way of doing it.
Thanks.
See below for a working example. A couple of notes:
Arrays in VBA are 0-based by default. This can be changed via Option Base 1 or Option Base 0 in the module header, but the safest approach is to simply specify both the lower and upper bounds when declaring the array (Dim categorys(5) --> Dim categorys(1 To 5))
Not sure what the purpose your - 1 + 1 served so I got rid of it: Int((5 - 1 + 1 --> Int((5
I split up the expression and added some intermediate variables to make things easier to read and maintain going forward (& categorys(Int((5 - 1 + 1) * Rnd + 1)).Name --> Dim RandomIndex...)
Strings are not objects in VBA, so they cannot have methods or properties like .Name
Public Sub SaveToDrive()
Dim categorys(1 To 5) As String
categorys(1) = "Adam"
categorys(2) = "James"
categorys(3) = "Henry"
categorys(4) = "William"
categorys(5) = "Keith"
Dim RandomIndex As Integer
RandomIndex = Int((5 * Rnd) + 1)
Dim FName As String
FName = categorys(RandomIndex)
ThisWorkbook.SaveAs FileName:="e:\" & FName
End Sub