Excel VBA Array of Arrays - 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

Related

How to merge three arrays in visual basic?

I would like merge three arrays in one array.
Dim arr() = 1 4 7 10
Dim arr2() = 2 5 8 11
Dim arr3() = 3 6 9 12
Dim arr4()
for i=0 to ubond.(arr1)+2
??????????????
Next
The result should be arr4()= {1 2 3 4 5 6 7 8 9 10 11 12}
Best Regards
I'd just concatenate and sort them with LINQ:
Dim arr4 = arr.Concat(arr2).Concat(arr3).OrderBy(Function(x) x)
Whether or not you call .ToArray() is optional and depends what you do with arr4. If you will enumerate it with a foreach loop you can leave it like above. If you will random access it or pass it round as an array of int then call ToArray on it
Make sure you Imports System.Linq
If you don't want to use LINQ, a simple loop:
Dim arr4() as New Integer(arr.Length * 3 - 1)
For x = 0 to arr.Length - 1 Step 1
arr4(3*x) = arr(x)
arr4(3*x+1) = arr2(x)
arr4(3*x+2) = arr3(x)
Next x
This works completely differently - the LINQ version would have made an array of 1 4 7 2 5 8 3 6 9 and then sorted it, this one puts the bits in the right order naturally, but if your data didn't sort this way the two approaches would produce different outputs!

Count number of non-empty fields in Excel VB array's column

I currently read a 2-dimensional range into an Excel VBA array like so:
Set Ws = Sheet1
Ws.Activate
LastRow = Ws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = Ws.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
ReDim elements(0 To LastRow - 2, 0 To LastCol - 2)
elements = Ws.Range(Cells(2, 1), Cells(LastRow, LastCol))
The range is 25 rows by 11 columns. However, not all cells in the range have values so some of the values in the array are 'empty'.
col A has 25 items
col B has 16
col K has 12...
I need to loop through this array and create a second array, which will be a "Cartesian product" of the values from the first one. In order to determine how many times I need to loop I need to figure out how many items there are in each of the arrays columns ("dimensions"?).
Here is an attempt of my loop:
Row = 0
For i = 1 To 25 'numElements in column 1
For j = 1 To 3 'numElements in column 6
For k = 1 To 5 'numElements in column 7
For l = 1 To 14 'numElements in column 8
For m = 1 To 6 'numElements in column 10
For n = 1 To 12 'numElements in column 11
cartesian(Row, 0) = elements(i, 0)
cartesian(Row, 1) = elements(i, 1)
cartesian(Row, 2) = elements(i, 2)
cartesian(Row, 3) = elements(i, 3)
cartesian(Row, 4) = elements(i, 4)
cartesian(Row, 5) = elements(j, 5)
cartesian(Row, 6) = elements(k, 6)
cartesian(Row, 7) = elements(l, 7)
cartesian(Row, 8) = elements(l, 8)
cartesian(Row, 9) = elements(m, 9)
cartesian(Row, 10) = elements(n, 10)
Row = Row + 1
Next n
Next m
Next l
Next k
Next j
Next i
Any help appreciated :)
EDIT 1:
This is the range that I read into array1:
Austria sem jan
Belgium gdn feb
France mar
US apr
may
jun
I need to be able to count how many "items" there are in column 1, column 2 and column 3 in order to multiply them. That way I will know how big I need to ReDim second array.
This is what I need in the array 2 and to finally write back into another sheet:
Austria sem jan
Austria sem feb
Austria sem mar
Austria sem apr
Austria sem may
Austria sem jun
Austria gdn jan
Austria gdn feb
Austria gdn mar
Austria gdn apr
Austria gdn may
Austria gdn jun
Belgium sem jan
Belgium sem feb
Belgium sem mar
Belgium sem apr
Belgium sem may
Belgium sem jun
Belgium gdn jan
Belgium gdn feb
Belgium gdn mar
Belgium gdn apr
Belgium gdn may
Belgium gdn jun
etc.
This should do it like you need it in a decent amount of time... still will take some time for ~300k entries:
Option Explicit
Sub getMyList()
'set input
Dim inputVal As Variant
'get input values
With ThisWorkbook.Worksheets("Sheet1")
inputVal = .Range(.Cells(1, 1), .Cells(.Cells.Find("*", , , , 1, 2).Row, .Cells(1, 1).End(xlToRight).Column)).Value
End With
'set count array
Dim xCounts() As Variant
ReDim xCounts(1 To UBound(inputVal, 2))
Dim i As Long, j As Long
For i = 1 To UBound(xCounts)
j = 1
While inputVal(j, i) <> "" And j < UBound(inputVal)
j = j + 1
Wend
'xCounts(i) = j - 1 'will skip last value if it is at the last row
xCounts(i) = j + (inputVal(j, i) = "") 'new one will work as wanted
Next
'set output sizes
Dim outVal() As Variant
ReDim outVal(1 To Application.Product(xCounts), 1 To UBound(xCounts))
'runner sets
Dim colRunner As Long, rowRunner As Long, copyRunner As Long
Dim itemRep As Long, listRep As Long
For colRunner = 1 To UBound(xCounts)
rowRunner = 1
itemRep = 1
listRep = 1
'repeat whole list
For i = 1 To colRunner - 1
listRep = listRep * xCounts(i)
Next
'repeat each item
For i = colRunner + 1 To UBound(xCounts)
itemRep = itemRep * xCounts(i)
Next
'run the list for output
copyRunner = 1
For i = 1 To listRep
For copyRunner = 1 To xCounts(colRunner)
For j = 1 To itemRep
outVal(rowRunner, colRunner) = inputVal(copyRunner, colRunner)
rowRunner = rowRunner + 1
Next
Next
Next
Next
'output everything
ThisWorkbook.Worksheets("Sheet2").Cells(1, 1).Resize(UBound(outVal), UBound(outVal, 2)).Value = outVal
End Sub
The code should be easy to read (there is no real magic inside) :P
However, if any questions are left, just ask :)
EDIT
The xCounter simply hold the counts of all items for each column because this numbers are used lots of times.
For clarification: Let's assume you have a list like this:
A B C D E
1 1 1 1 1
2 2 2 2 2
3 3 3 3
4 4 4
5 5 5
6 6 6
7 7
8
(Used numbers for easy counting, also works with any strings)
xCounter will now be {8,2,6,7,3}. Now if you want to write down the column C then you need to know how many times each item needs to be repeated. This can be calculated by multiplying the counts of all columns which come later. For this case it would be 7 * 3 = 21 times. Also, you need to know how many items are in the list to loop through which will be 6. Then the whole list also needs to repeat itself which can be calculated by multiplying all counts of rows which are in front of it. That would be 8 * 2 = 16 times. This way also the 3 inner For ... Next loops are build up. ListRepeat(EachItem(ItemRepeat)).
To know which line in the output array is to be written you need a simple up counting value which is the RowCounter. Doing this directly into the sheet you would use a range which simply offsets one row down every time a value is written in a cell.
By this system you do every column completely seperated from the others because all you need are the products of the item counts of the leading and following columns (for which we have xCounter). Still we need to do this for each column so the outer loop is the column (colRunner).
Simply for not getting confused by having 4 loops using i, j, k, l inside each other I renamed the "runner" for the rows in the outVal to rowRunner and the one for the columns to colRunner. Having the upper and lower limits for the repeats directly set in front of the inner loops, I stayed with i and j. (Also they are not used for anything in that loops, they simply ensure the repeats by doing the same action mutiple times)
If I missed something or other questions pop up, just do it as it is always the right thing to do: ask. ;)

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

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.

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

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

Resources