How to fill in a dynamic combination of numbers into an array - arrays

In my Excel worksheet users can enter 1 to 5 rows of data in the form of minimum, maximum and step size values. I want to create an multidimensional array that has all the combinations of the data.
Is there a way to code this in VBA to dynamically size the array and loop through the cell values without knowing how many data items beforehand?
Example data of 3 rows of inputs (can be more or less)
Min, Max, Step
Data 1: 1, 10, 1
Data 2: 10, 50, 10
Data 3: 5, 25, 5
Total combinations is 250 (10 x 5 x 5)
Combo 1: 1, 10, 5
Combo 2: 1, 10, 10
Combo 3: 1, 10, 15
...
Thanks!

I found your question a little unclear but I believe the macro below does what you want.
If you have a variant Result, you can set Result to an array. You can then, in turn, set Result(1), Result(1)(1), Result(1)(1)(1) and so on to nested arrays. With suitable recursive routines I believe you could create the sort of array you seek of any size within the limits Excel. However, I think this approach would be very difficult to understand.
I do not believe there is a simpler way of creating an array with a variable number of dimensions. Changing the size of the dimensions is, however, not a problem.
Since you have a maximum of five dimensions, I have decided to go for a fixed number of dimensions with trailing, unused dimensions having a width of one. With your example (1 to 10 step 1, 10 to 50 step 10, 5 to 25 step 5), this would require:
Dim Result(1 To 10, 1 To 5, 1 To 5, 1 To 1, 1 To 1)
The first three dimensions have 10, 5 and 5 elements, ready to hold a range of values. The final two dimensions are just place holders.
You are getting your users to enter dimension details. I have loaded details from worksheet "Dyn Dims". For the test that matches your example, I set this worksheet to:
Min Max Step
1 10 1
10 50 10
5 25 5
I load this information to long array Requirements(1 To 3, 1 To 5). The columns are minimum, maximum and step. The rows allow for a maximum of five dimensions. If column 3 (step) is zero, the dimension is not used. I do not allow for negative step values but indicate where changes would be required if this was necessary.
You will need to initialise this array from the data entered by your users.
From array Requirements, the macro calculates the number of elements in each dimension. I have tested this calculation with values, such as 1 step 2 to 10, where there is no value for N such that Min + N * Step = Max.
The macro then dimensions array Result as necessary.
You do not say what values you want within the array so I have set them to values of the form "N:N:N" where the Ns are the values from the Min-To-Max-Step calculation. I have explained this in the macro and will not repeat myself here.
Finally, I output the contents of the array to a file named for the date and time. With your example the output is:
Dimensions
1 2 3 Value
1 1 1 1:10:5
2 1 1 2:10:5
3 1 1 3:10:5
4 1 1 4:10:5
5 1 1 5:10:5
6 1 1 6:10:5
7 1 1 7:10:5
8 1 1 8:10:5
9 1 1 9:10:5
10 1 1 10:10:5
1 2 1 1:20:5
: : : :
5 5 5 5:50:25
6 5 5 6:50:25
7 5 5 7:50:25
8 5 5 8:50:25
9 5 5 9:50:25
10 5 5 10:50:25
I believe I have included enough comments to explain the macro but come back with questions if necessary.
Option Explicit
Sub DD()
Const ColReqMin As Long = 1
Const ColReqMax As Long = 2
Const ColReqStep As Long = 3
Dim DimCrnt As Long
Dim Entry(1 To 5) As Long
Dim EntryStepped As Boolean
Dim FileOutNum As Long
Dim Index(1 To 5) As Long
Dim IndexStepped As Boolean
Dim NumEntries(1 To 5) As Long
Dim Requirements(1 To 3, 1 To 5) As Long
Dim Result() As String
Dim RowDDCrnt As Long
Dim Stg As String
Dim Value As String
' Load Requirements with the required ranges
With Worksheets("Dyn Dims")
RowDDCrnt = 2 ' First data row of worksheet Dyn Dims
' Note this macro does not check for blank lines in the middle
' of the table.
For DimCrnt = 1 To 5
If IsEmpty(.Cells(RowDDCrnt, ColReqStep)) Then
' No step value so this dimension not required for this run
Requirements(ColReqStep, DimCrnt) = 0
Else
Requirements(ColReqMin, DimCrnt) = .Cells(RowDDCrnt, ColReqMin)
Requirements(ColReqMax, DimCrnt) = .Cells(RowDDCrnt, ColReqMax)
Requirements(ColReqStep, DimCrnt) = .Cells(RowDDCrnt, ColReqStep)
End If
RowDDCrnt = RowDDCrnt + 1
Next
End With
' Calculate number of entries for each dimension
For DimCrnt = 1 To 5
If Requirements(ColReqStep, DimCrnt) = 0 Then
' Dummy dimension
NumEntries(DimCrnt) = 1
Else
NumEntries(DimCrnt) = (Requirements(ColReqMax, DimCrnt) - _
Requirements(ColReqMin, DimCrnt) + _
Requirements(ColReqStep, DimCrnt)) \ _
Requirements(ColReqStep, DimCrnt)
End If
Next
' Size array
ReDim Result(1 To NumEntries(1), _
1 To NumEntries(2), _
1 To NumEntries(3), _
1 To NumEntries(4), _
1 To NumEntries(5))
' Initialise entry for each dimension to minimum value, if any,
' and index for each dimension to 1
For DimCrnt = 1 To 5
Index(DimCrnt) = 1
If Requirements(ColReqStep, DimCrnt) <> 0 Then
Entry(DimCrnt) = Requirements(ColReqMin, DimCrnt)
End If
Next
' Starting with Entry(1), this loop steps the entry if the dimension is used.
' If the stepped entry is not greater than the maximum, then this repeat of
' the loop has finished. If the stepped entry is greater than the maximum,
' it is reset to its minimum and the next entry stepped and checked in the
' same way. If no entry is found that can be stepped, the loop is finished.
' If the dimensions after all 1 to 3 step 1, the values created by this loop
' are:
' 1 1 1 1 1
' 2 1 1 1 1
' 3 1 1 1 1
' 1 2 1 1 1
' 2 2 1 1 1
' 3 2 1 1 1
' 1 3 1 1 1
' 2 3 1 1 1
' 3 3 1 1 1
' 1 1 2 1 1
' 2 1 2 1 1
' 3 1 2 1 1
' : : : : :
' 3 3 3 3 3
Do While True
' Concatenate entries to create value for initial element
' or for element identified by last loop
Value = Entry(1)
For DimCrnt = 2 To 5
If Requirements(ColReqStep, DimCrnt) = 0 Then
Exit For
End If
Value = Value & ":" & Entry(DimCrnt)
Next
Result(Index(1), Index(2), Index(3), Index(4), Index(5)) = Value
' Find an entry to step
EntryStepped = False
For DimCrnt = 1 To 5
If Requirements(ColReqStep, DimCrnt) = 0 Then
Exit For
End If
Index(DimCrnt) = Index(DimCrnt) + 1
Entry(DimCrnt) = Entry(DimCrnt) + _
Requirements(ColReqStep, DimCrnt)
' ### Changes required her if a negative step value is allow
If Entry(DimCrnt) <= Requirements(ColReqMax, DimCrnt) Then
' This stepped entry is within permitted range
EntryStepped = True
Exit For
End If
' This entry past its maximum so reset to minimum
' and let for loop step entry for next dimension
Index(DimCrnt) = 1
Entry(DimCrnt) = Requirements(ColReqMin, DimCrnt)
Next
If Not EntryStepped Then
' All elements of Result initialised
Exit Do
End If
Loop
' All elements of Result initialised
' Output values as test.
FileOutNum = FreeFile
Open ActiveWorkbook.Path & "\" & Format(Now(), "yymmdd hhmmss") & ".txt" _
For Output As #FileOutNum
' Initialise Index
For DimCrnt = 1 To 5
Index(DimCrnt) = 1
Next
' Create header line for table
Print #FileOutNum, "Dimensions"
Stg = ""
For DimCrnt = 1 To 5
If Requirements(ColReqStep, DimCrnt) = 0 Then
Exit For
End If
Stg = Stg & Right(" " & DimCrnt, 4)
Next
Stg = Stg & " Value"
Print #FileOutNum, Stg
' Similar logic to loop that intialised Result but using Index and UBound.
Do While True
' Output initial element or element identified by previous loop
Stg = ""
For DimCrnt = 1 To 5
If Requirements(ColReqStep, DimCrnt) = 0 Then
Exit For
End If
Stg = Stg & Right(" " & Index(DimCrnt), 4)
Next
Stg = Stg & " " & Result(Index(1), Index(2), Index(3), Index(4), Index(5))
Print #FileOutNum, Stg
' Identify next element, if any
IndexStepped = False
For DimCrnt = 1 To 5
If Requirements(ColReqStep, DimCrnt) = 0 Then
Exit For
End If
Index(DimCrnt) = Index(DimCrnt) + 1
If Index(DimCrnt) <= UBound(Result, DimCrnt) Then
IndexStepped = True
Exit For
Else
Index(DimCrnt) = 1
End If
Next
If Not IndexStepped Then
' All entries output
Exit Do
End If
Loop
Close #FileOutNum
End Sub

Related

How to assign an array's values to a range?

I'm trying to assign a 1-dimensional array's values to cell range.
For example; my array has 23 items (every item randomized from 1 to 5) and my cell range is range A1 to I7.
I want to assign every value of my array to this cell range randomly.
I randomize the cell values with my array but my array's values are not completely assigned to cells.
Sub define_ore_body()
Dim lb_grade As Integer, ub_grade As Integer
Dim ore_body(1 To 23) As Variant
Dim i As Integer, j As Integer, k As Integer
Dim a As Object
Dim b As Range
Application.ScreenUpdating = False
'my selected range area A1toI7
Set b = Application.Range("A1:I7")
Set a = Application.Cells
'******* low and high ore bound ******
lb_grade = InputBox("Enter lowest ore grade:")
ub_grade = InputBox("Enter highest ore grade:")
'The reason why I do it as follows is that if the random lower bound does not start from 1,
'the largest random number it generates is 2 more than the value I have entered, so
If lb_grade > 1 Then
ub_grade = ub_grade - 2
End If
'******* Random Array ******
'array has 23 items
For i = 1 To 23
ore_body(i) = Int((ub_grade * Rnd) + lb_grade)
Next i
'******* filling random cells with my array******
k = 1
For Each a In b
If a.Value = "" And k < 23 Then
b(Int(7 * Rnd + 1), (8 * Rnd + 1)) = ore_body(k)
ElseIf a.Count > 23 And k > 23 Then
Exit For
Else
k = k + 1
End If
Next a
'******* after filling cell now fill empty cells with Zero******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) = "" Then
Cells(i, j) = 0
Else
End If
Next j
Next i
'******* Coloring only containing array values******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) > 0 Then
Application.Cells(i, j).Interior.ColorIndex = 38
Else
End If
Next j
Next i
End Sub
The array contains 23 items that initialize to Variant/Empty:
Dim ore_body(1 To 23) As Variant
Make that 63 items that initialize to 0:
Dim ore_body(1 To 63) As Long
The rest of the code will now populate the first 23 elements, because that's what the loop does:
For i = 1 To 23
If you want the loop to run through all indexes, consider using LBound and UBound operators to programmatically retrieve the lower and upper boundaries of the array, respectively:
For i = LBound(ore_body) To UBound(ore_body)
Note that you have 23 hard-coded in several places, which is going to make it harder than necessary to modify if/when that 23 needs to be come a 25. Consider replacing every occurrence of it by a Const:
Const ElementCount As Long = 23
Then every instance of 23 can become ElementCount, and then when it needs to become 25 then there's only one place that needs any code to change.
Loop through the array.
Set a to a random cell in the range A1:I7.
If cell is empty put the value from the array in the cell, if it
isn't repeat step 2
Sub define_ore_body()
Dim lb_grade As Integer, ub_grade As Integer
Dim ore_body(1 To 23) As Variant
Dim i As Long, j As Long, k As Long
Dim a As Range
Dim b As Range
Application.ScreenUpdating = False
'my selected range area A1:I7
Set b = Application.Range("A1:I7")
' clear A1:A17
b.Clear
'******* low and high ore bound ******
lb_grade = InputBox("Enter lowest ore grade:")
ub_grade = InputBox("Enter highest ore grade:")
'The reason why I do it as follows is that if the random lower bound does not start from 1,
'the largest random number it generates is 2 more than the value I have entered, so
If lb_grade > 1 Then
ub_grade = ub_grade - 2
End If
'******* Random Array ******
'array has 23 items
For i = 1 To 23
ore_body(i) = Int((ub_grade * Rnd) + lb_grade)
Next i
'******* filling random cells with my array******
For k = 1 To 23
Do
Set a = b.Cells(Int(7 * Rnd) + 1, Int(9 * Rnd) + 1)
Loop Until a.Value = ""
a.Value = ore_body(k)
Next k
'******* after filling cell now fill empty cells with Zero******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) = "" Then
Cells(i, j) = 0
Else
End If
Next j
Next i
'******* Coloring only containing array values******
For i = 1 To 7
For j = 1 To 9
If Cells(i, j) > 0 Then
Application.Cells(i, j).Interior.ColorIndex = 38
Else
End If
Next j
Next i
End Sub

swapped rows vba code in excel

I'm trying to generate combinations id_users in excel that they have a relation..so I used this sample code to gave me this result:
the input is a pivot table :
' id_row id_users
10 1
2
3
66 4
11
this is my output
'source target label
1 2 10
1 3 10
2 3 10
4 11 66
But it gave me this result :
'source target label
1 2 10
1 3 10
2 1 10
2 3 10
3 1 10
3 2 10
4 11 66
11 4 66
as u see i didn't want to show the swapped rows too it's okay if it show duplicate row..but i don't want to show the swapped data..like : 1 2 and 2 1
it doesn't mean anything just a repeated info like : a with b has a relation and then u saw that b with a has a relation ..and it's just a repeated of an info that first i have it...
in my code is it's show the data array sq user_1 that not equal with the data in sqq user_2 , but also I want to show the data that are not called in pervious
sq user_1 :
'
'get the combinationsin the pivot table for this topic
sq = Range(rTopic, rTopic.End(xlDown).Offset(-1)).Offset(, 1).Resize(, 2).SpecialCells(2, 1).Value
'get the unique combinations of persons
sUniq = " "
For lUser_2 = 1 To UBound(sq, 1)
If InStr(sUniq, " " & sq(lUser_2, 2) & " ") = 0 Then
sUniq = sUniq & sq(lUser_2, 2) & " "
End If
Next
sqq = Split(Trim(sUniq))
'loop over user id's and generate combinations
For lUser_1 = 1 To UBound(sq, 1)
For lUser_2 = 0 To UBound(sqq)
If sq(lUser_1, 2) & "" <> sqq(lUser_2) Then
'we found a new combination, output to screen
Range(sStartingCellOutput).Offset(lRowOffset, lColOffset).Resize(1, 3).Value = Array(sq(lUser_1, 2), sqq(lUser_2), rTopic.Value)
'increment the counter
lRowOffset = lRowOffset + 1
If lRowOffset >= Rows.count Then
lRowOffset = 0
lColOffset = lColOffset + 4
End If
End If
Next
Next
I editted it to explain more in my code..just plz i need a samll help ? if my Q is not clear just comment for me...thanks
You need to add another space to the value you're checking
If InStr(sUniq, " " & sq(lUser_2, 2) & " ") = 0 Then

Excel VBA Array of Arrays

I am trying to create an array of arrays inside of the macros of Excel. Here is my problem... I am creating a year calendar and want to highlight dates inside that calendar.
I have a range of dates in a worksheet. These would be any type of dates I want to remember, etc. I read them in and then create the calendar and make these a different dates a different background color.
9/24/2015
1/20/2015
4/5/2015
9/30/2015
1/1/2015
In my limited thinking I would read them in, Group them by month (year doesn't matter) and then put the dates associated with that month.
9 -> 24, 30
1 -> 20, 1
4 -> 5
Here is what I have so far
'Set Variables
Dim ImportantDays As Variant
Dim id As Integer
Dim tempSplitDateArray() As Integer
'Grab the dates from the entered WorkSheet
ImportantDays = Worksheets("MainData").Range("E4:E19")
'Loop through the dates entered
For id = LBound(ImportantDays, 1) To UBound(ImportantDays, 1)
If ImportantDays(id, 1) <> "" Then
tempSplitDateArray() = Split(ImportantDays(id, 1), "/")
'--I now have tempSplitDateArray(0) = month
'--tempSplitDateArray(1) = day
'------------------------------------
'-- Not sure of my next step here
'------------------------------------
End If
Next id
I know I can have a 2D array, but how do I keep track of which array slot is open? I have this variable (the 12 is the months, the 16 is the total number of dates allowed).
Dim monthlyDates(12, 16) As Variant
Ideally I would store all the September months in monthlyDates(9) or something like that, but I am at a loss as to ...
How to keep track when storing them?
How to access and loop through the values when that particular month is being created?
Any thoughts?
If I understand correctly, I think this option is right for you ...
Sub test()
Dim id&, z&, oCell As Range, Key, MKey
Dim I_Month As Object: Set I_Month = CreateObject("Scripting.Dictionary")
Dim I_Day As Object: Set I_Day = CreateObject("Scripting.Dictionary")
Dim Cnt As Object: Set Cnt = CreateObject("Scripting.Dictionary")
Dim Month_count As Object: Set Month_count = CreateObject("Scripting.Dictionary")
id = 1
'Grab the dates from the entered WorkSheet
For Each oCell In Worksheets("MainData").Range("E4:E19")
I_Month.Add id, Month(oCell.Value)
I_Day.Add id, Day(oCell.Value)
id = id + 1
Next
id = 12
z = 0
While id <> 0
For Each Key In I_Month
If I_Month(Key) = id Then z = z + 1
Next
Cnt.Add id, z
id = id - 1: z = 0
Wend
For Each Key In I_Month
For Each MKey In Cnt
If MKey = I_Month(Key) Then
id = Cnt(MKey)
Exit For
End If
Next
Month_count.Add Key, id
Next
For Each Key In I_Month
Debug.Print Key, I_Month(Key), I_Day(Key), Month_count(Key)
Next
End Sub
result
Key Month Day Count of the Month iteration
1 6 22 4
2 10 24 2
3 6 15 4
4 10 28 2
5 1 14 3
6 1 9 3
7 11 15 1
8 1 24 3
9 6 2 4
10 3 21 1
11 12 26 2
12 5 25 2
13 2 23 1
14 12 7 2
15 5 31 2
16 6 5 4

VBA function to iterate through cells, replacing a cell with the relative column header value

I'm trying to convert a data matrix to a new standard that should fit a specific analysis software.
The initial matrix looks like this:
real char num 10 10 25 26 26 56
--------------------------------
state num 1 2 9 4 6 3
--------------------------------
name 1 0 0 1 1 0 1
name 2 1 0 0 0 0 0
name 3 0 1 1 0 0 1
name 4 0 1 0 0 1 0
name 5 1 0 0 0 0 0
name 6 0 0 1 0 1 0
I've been trying to achieve this:
real char num 10 10 25 26 26 56
--------------------------------
state num 1 2 9 4 6 3
--------------------------------
name 1 0 0 9 4 0 3
name 2 1 0 0 0 0 0
name 3 0 2 9 0 0 3
name 4 0 2 0 0 6 0
name 5 1 0 0 0 0 0
name 6 0 0 9 0 6 0
Essentially, what I'm trying to do is:
1. For every column, look in every cell for a number other than 0;
2. If this condition is achieved, replace the cell value with the relative "state" header. Meaning, for instance, if A4 <> 0, then replace it with A3 value.
The code I've used is as follows:
Sub Iterate_replace()
Sheets("matrix").Select
Dim r As Range, cell As Range, state As Range
Set r = Range("C3")
Set state = Range("C2")
For Each cell In r
If cell.Value <> "0" Then
cell.Value = state.Value
End If
Next
End Sub
It works fine in a defined range of one single column, but I'm having trouble making it dynamic. Should I use R1C1 notation to refer to the cells in the range? Everything related that I could find never explicits how to make this iteration more flexible. Should I use nested loops? Loops are a very difficult thing for me to grasp, still, so, please be patient.
I'd appreciate if anyone could point me to the right direction. Thanks!
I am assuming that there is nothing else on each sheet than the matrix in question. In that case you should be able to make you procedure dynamic by modifying your code like the following:
Sub Iterate_replace()
Sheets("matrix").Select
Dim i As Integer, j As Integer
Dim state As Range
Set state = Range("C2")
'Loops through each row and each column in matrix
For i = state.Column To ActiveSheet.Cells(state.Row, Columns.Count).End(xlToLeft).Column
For j = state.Row + 1 To ActiveSheet.Cells(Rows.Count, state.Column).End(xlUp).Row
If Cells(j, i).Value <> 0 Then
Cells(j, i).Value = Cells(state.Row, i).Value
End If
Next j
Next i
End Sub
This will loop through each column and each row in your matrix if you have defined in what cell the most left state value is located.

VBA - put values from 2D array to 2 or more cells

I'm trying to figure out how to put values from a [N x 2] matrix to cells on the same row on a different worksheet.
The matrix, which changes, is something like:
1 0
1 2
1 3
2 0
2 1
2 2
... so on.
On a different sheet, using the items in the matrix, I want to create a vector that omits the zero, such as:
A B
1 1 1
2 1 2
3 1 3
4 2 1
5 2 2
... so on.
I already have an array filled with the values from the matrix. I am having problems trying to extract values from the array.
Eventually, there will be certain criteria and some combinations, so # of columns and rows will increase. So, I need to do this in VBA. Can anyone guide me in the right direction or provide some example code that I can reference?
Please let me know if I need to clarify anything.
A sample for your reference
Sub testArr()
'Declare a 4-by-2 matrix
Dim Data(3, 1) As Variant
Dim i As Long, j As Long
For i = 0 To UBound(Data, 1)
For j = 0 To UBound(Data, 2)
Data(i, j) = Int((10 - 1 + 1) * Rnd + 1)
Next j
Next i
'You extract a value from the array like this
MsgBox "data(2,1) = " & Data(2, 1)
End Sub

Resources