I have 3 arrays of size 803500*1 with the following details:
Rid: It can contain any number
RidID: It contains elements from 1 to 184 in random order. Each element appears multiple times.
r: It contains elements 0,1,2,...12. All elements (except zero) appear nearly 3400 to 3700 times at random indices in this array.
Following may be useful for generating sample data:
Rid = rand(803500,1);
RidID = randi(184,803500,1);
r = randi(13,803500,1)-1; %This may not be a good sample for r as per previously mentioned details?
What I want to do?
I want to calculate the sum of those entries of Rid which correspond to each positive unique entry of r and each unique entry of RidID.
This may be clearer with the code which I wrote for this problem:
RNum = numel(unique(RidID));
RSum = ones(RNum,12); %Preallocating for better speed
for i=1:12
RperM = r ==i;
for j = 1:RNum
RSum(j,i) = sum(Rid(RperM & (RidID==j)));
end
end
Issue:
My code works but it takes 5 seconds on average on my computer and I have to do this calculation nearly a thousand times. If this time be reduced from 5 seconds to atleast half of it, I'll be very happy. But how do I optimize this? I don't mind if it is made better with vectorization or any better written loop.
I am using MATLAB R2017b.
You can use accumarray :
u = unique(RidID);
A = accumarray([RidID r+1], Rid);
RSum = A(u, 2:13);
This is slower than accumarray as suggested by rahnema, but using findgroups and splitapply may save memory.
In your example, there may be thousands of zero-valued elements in the resulting matrix, where a combination of RidID and r does not occur. In this case a stacked result would be more memory efficient, like so:
RidID | r | Rid_sum
-------------------------
1 | 1 | 100
2 | 1 | 200
4 | 2 | 85
...
This can be achieved with the following code:
[ID, rn, RidIDn] = findgroups(r,RidID); % Get unique combo ID for 'r' and 'RidID'
RSum = splitapply( #sum, Rid, ID ); % Sum for each ID
output = table( RidIDn, rn, RSum ); % Nicely formatted table output
% Get rid of elements where r == 0
output( output.rn == 0, : ) = [];
You could convert this to the same output as the accumarray method, but it's already a slower method...
% Convert to 'unstacked' 2D matrix (optional)
RSum = full( sparse( 1:numel(Ridn), 1:numel(rn), RSum ) );
I have the following data:
And my goal is to do this:
Recursive sub that will create an array filled with the materials.
Everytime a material is set as "Crafted", the array will add another sub-material at the same dimension adding a ".1". Example: If we look at bow, it's crafted, so the array would look like this when finished: Material: array(0,0,0) = Wood, Quantity: array(0,0,1) = 2, Level: array(0,0,2) = 1.
But then, the sublevel would become: Material: array(0,1,0) = Branch, Quantity: array(0,1,1) = 2, Level: array(0,1,2) = 1.1
And since Branch is crafted: Material: array(0,2,0) = Tree, Quantity: array(0,2,1) = 1, Level: array(0,2,2) = 1.1.1.
And then: Material: array(0,3,0) = Leaf, Quantity: array(0,3,1) = 9, Level: array(0,3,2) = 1.2.
It would then look for the next material "Rope" and go on: Material: array(1,0,0) = Rope, Quantity: array(1,0,1) = 1, Level: array(1,0,2) = 1, Material: array(1,1,0) = Web, Quantity: array(1,1,1) = 10, Level: array(1,1,2) = 2.1 and so on.
My main problem is that I am not that familiar with recursive code and my logic seems wrong, so I figured I would look for help and ask here how it could be done.
Here is my code so far, it's partially working:
Sub Look(ByRef arrayMaterials)
Dim item
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ActiveSheet
lastColumn = .Cells(j + 2, .Columns.Count).End(xlToLeft).Column
End With
For i = 0 To lastRow
For y = 0 To lastColumn
item = Cells(i + 2, 1).Value
If Cells(i + 1, y + 1).Value = item And Cells(i + 1, y + 1).Value <> "Item" Then
arrayMaterials = ReDimPreserve(arrayMaterials, i, i, y)
arrayMaterials(i - 1, i - 1, y - 2) = Cells(i + 1, y + 1).Value
arrayMaterials(i - 1, i - 1, y - 1) = Cells(i + 1, y + 2).Value
level = level & CInt(Right(Cells(1, y + 3), 2))
arrayMaterials(i - 1, i - 1, y) = level
level = CInt(Right(Cells(1, y + 3), 2))
If Cells(i + 1, y + 1).Value <> "Resource" Then
level = level & "."
Look (arrayMaterials)
End If
End If
Next
Next
Look (arrayMaterials)
End Sub
Called by:
Sub CallLook()
Dim arrayMaterials(1, 1, 1)
Look (arrayMaterials)
End Sub
Also (to get rid of the Preserve limitation of the last dimension):
Public Function ReDimPreserve(aArrayToPreserve, nNewFirstUBound, nNewSecondUBound, nNewLastUBound)
ReDimPreserve = False
'check if its in array first
If IsArray(aArrayToPreserve) Then
'create new array
ReDim aPreservedArray(nNewFirstUBound, nNewSecondUBound, nNewLastUBound)
'get old lBound/uBound
nOldFirstUBound = UBound(aArrayToPreserve, 1)
nOldSecondUBound = UBound(aArrayToPreserve, 2)
nOldLastUBound = UBound(aArrayToPreserve, 3)
'loop through first
For nFirst = LBound(aArrayToPreserve, 1) To nNewFirstUBound
For nSecond = LBound(aArrayToPreserve, 2) To nNewSecondUBound
For nLast = LBound(aArrayToPreserve, 3) To nNewLastUBound
'if its in range, then append to new array the same way
If nOldFirstUBound >= nFirst And nOldSecondUBound >= nSecond And nOldLastUBound >= nLast Then
aPreservedArray(nFirst, nSecond, nLast) = aArrayToPreserve(nFirst, nSecond, nLast)
End If
Next
Next
Next
'return the array redimmed
If IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArray
End If
End Function
The variable "level" is declared globally.
Can you help me out figure what's not working with this code please?
I think I might have some of the indexes (i and y) wrong. I am not that experienced with coding either.
All the help is appreciated.
EDIT: As requested in the comments, here is the output of both the arry and Excel:
Array:
(0,0,0) = Wood, 2, 1
(0,1,0) = Branch, 2, 1.1
(0,1,1) = Tree, 1, 1.1.1
(0,2,0) = Leaf, 9, 1.2
(1,0,0) = Rope, 1, 2
(1,1,0) = Web, 10, 2.1
(1,1,1) = Spider, 5, 2.1.1
(2,0,0) = Crystal, 3, 3
(3,0,0) = Shard, 8, 4
(4,0,0) = Plumes, 1, 5
(4,1,0) = Bird, 1, 5.1
Excel (each entry is a row, the item and quantity are on the same column, due to restrictions, I cannot add a column):
Bow (is already on the other sheet, no need to add it, "-" are indents)
-Wood - 2
--Branch - 4 (2 Wood, so 4 Branches)
---Tree - 4
--Leaf - 18
-Rope - 1
--Web - 10
---Spider - 50
-Crystal - 3
-Shard - 8
-Plumes - 1
--Birds - 1
I hope it gives you a better idea of what I need.
EDIT: 2015-07-13 - Added the new code as per Tony Dallimore's suggestions:
Please note that this is not the finished product, I still have to pass the item I want the materials for and code the output, I wanted to make sure I would understand everything up to that point before going further.
On my data sheet I got a button that calls sFilltypes.
Public Type tComponent RowMaterial As Long Quantity As Long End Type
Public Type tMaterial Name As String Crafted As Boolean Used As Boolean Component() As tComponent End Type
Sub sFillTypes()
Dim count
Dim Materials() As tMaterial
With ActiveSheet
lastRow = .Cells(.Rows.count, "A").End(xlUp).Row
End With
ReDim Materials(1 To lastRow - 1)
For i = 2 To lastRow
count = 0
With ActiveSheet
lastColumn = .Cells(i, .Columns.count).End(xlToLeft).Column
For k = 1 To lastColumn
If Left(Cells(1, k), 8) = "Material" And Cells(1, k).Value <> "" Then
count = count + 1
End If
Next
End With
ReDim Materials(i - 1).Component(1 To 1)
If UBound(Materials(i - 1).Component, 1) <= count Then
ReDim Materials(i - 1).Component(1 To count)
Else
Erase Materials(i - 1).Component
End If
Materials(i - 1).Name = Cells(i, 1).Value
If Cells(i, 2).Value = "Crafted" Then
Materials(i - 1).Crafted = "True"
Else
Materials(i - 1).Crafted = "False"
End If
For y = 1 To lastColumn + 1
If InStr(Cells(1, y).Value, "Material") Then
For Z = 1 To lastRow
If Cells(i, y).Value = Cells(Z, 1).Value Then
Materials(i - 1).Component(Right(Cells(1, y), 2)).RowMaterial = Z
Materials(i - 1).Component(Right(Cells(1, y), 2)).Quantity = Cells(i, y + 1)
End If
Next
End If
Next
Next
End Sub
Bow (is already on the other sheet, ...
I doubt this is a good idea.
With your demonstration data, “bow” is the only material that is not a component of something else. Will this be true of your real data? How will you know which elements of the array relate to which row in the worksheet?
Perhaps more importantly, the data required for the next step of processing is spread across two sources. You may be saving space (the array will be a little smaller) but this makes your code more complex and slower. I remember when space was tight (the first commercial computer for which I was a programmer had between 45 and 1000Kb † of memory for the operating system and 16 users) and we would accept increased complexity and slower runtime as a necessary price for fitting our programs into the memory available. You do not have to make that sacrifice. A simple program is quicker to write, easier to maintain and more reliable so start simple.
† I am not joking; I really do mean the maximum memory was 1Mb.
My understanding is you wish to transfer the data within the worksheet to memory so it is arranged more conveniently for processing. I find it difficult to see how your array could be convenient for anything. There is also the complexity of the processing necessary to create it. How long did you spend writing ReDimPreserve?
Please consider the following alternative structures.
| 1 | 2 | 3| 4| 5| 6| 7| 8| 9|10|11|12|
--|-------|--------|--|--|--|--|--|--|--|--|--|--|
1|Bow |Crafted | 2| 2| 3| 1| 5| 3|10| 8| 6| 1|
2|Wood |Crafted | 4| 2|12| 9|
3|Rope |Crafted | 8|10|
4|Branch |Crafted |13| 1|
5|Crystal|Resource|
6|Plumes |Crafted | 7| 1|
7|Bird |Resource|
8|Web |Crafted |11| 5|
9|String |Resource|
10|Shard |Resource|
11|Spider |Resource|
12|Leaf |Resource|
13|Tree |Resource|
This is called a ragged array because each row is a different length. This is logically the same as the worksheet. The values in columns 1, 2, 4, 6, 8, 10 and 12 are unchanged. The words in columns 3, 5, 7, 9 and 11 have been replaced by row numbers. For example: “Wood” has been replaced by “2” and “Rope” has been replaced by “3” where “2” and “3” are the rows holding details of Wood and Rope. (I created this table by hand but I am sure you can see the idea even if there are mistakes.
I hope you can see that getting from Bow to each of its components (Wood, Rope, Crystal, Shard and Plumes), and from Wood to its components (Branch and Leaf), would not be difficult. I also hope you can see it would be no major problems in converting the worksheet to this array.
Don’t worry at this stage how you create a ragged array rather than a square or cube array. At this stage I want you to think about data structures. Get the correct data structure and the program structure will be easy. With the wrong data structure, the program will be from difficult to impossible to code.
The structure above is simple but not self-documenting. Is column 7 a material or a quantity? For this problem, it may not be important for the structure to be self-documenting but for more complex problems it will be.
Long, String, Double and Boolean are intrinsic data types which come with the programming language. Often these intrinsic data types are enough but sometimes they are not. All the general purpose languages I know have some means of building more complex data types from these simple data types. Most languages call these complex data types “structures” but VBA calls them “user types”. Consider:
Type tComponent
RowMaterial As Long
Quantity As Long
End Type
Type tMaterial
Name As String
Crafted As Boolean
Component() As tComponent
End Type
The statements Type xxx to End Type define a user type. I always seem to want to use the same name for a type and a variable. One of my conventions is to have a leading “t” for a type name.
I first define a component of a crafted material. A component corresponds to columns (3,4), (5,6) and so on. I then define a material which has a name, a Boolean to record crafted or resource and an array of components. If a material is a resource, Crafted will be False and Component will not be used. If a material is crafted, Crafted will be True and Component will be ReDimed as appropriate and value stored.
Consider how Type tMaterial relates to a worksheet row. Column 1 contains a name and column 2 contains “Crafted” or “Resource”. I have replaced column 2 with a Boolean variable but that is just a different way of encoding the same information. Type tComponent, which contains a row number identifying the component and a quantity, matches the column pairs (3, 4), (5, 6) and so on. The big difference is tMaterial is self-documenting. If you return to these macros in six or twelve months which of these two approaches will be easier to understand? I believe that approach 2 will be the easier. If a macro, or any other program, is to be maintained to meet changing requirements, making life easy for the maintenance programmer is a very important consideration; after all, you might be that maintenance programmer.
The following code shows how these user types would be used:
Sub ShowConcept()
Dim Materials() As tMaterial
ReDim Materials(1 To 13)
Materials(1).Name = "Bow"
Materials(1).Crafted = True
ReDim Materials(1).Components(1 To 5)
Materials(1).Components(1).RowMaterial = 2
Materials(1).Components(1).Quantity = 2
Materials(1).Components(2).RowMaterial = 3
Materials(1).Components(2).Quantity = 1
Materials(1).Components(3).RowMaterial = 5
Materials(1).Components(3).Quantity = 3
' : : :
Materials(2).Name = "Wood"
Materials(2).Crafted = True
ReDim Materials(2).Components(1 To 2)
Materials(2).Components(1).RowMaterial = 4
Materials(2).Components(1).Quantity = 2
Materials(2).Components(2).RowMaterial = 12
Materials(2).Components(2).Quantity = 8
' : : :
End Sub
The two data structures above are logically the same; they just demonstrate two methods of achieving the same effect. I have not mentally tested the data structure yet although it feels about right. The next step is to “use” this structure. It may be necessary to modify or even discard my first attempt at an appropriate data structure for your problem but I hope not.
You need three macros. You need one macro to create the array from the original worksheet and another to create the new worksheet from the array. With your demonstration data there is only one material that is not a component of another. You could create a macro that output the components of row 1 of the array (row 2 of the worksheet). But your real data might have several such “unused” materials and, I assume, you would wish all of them to be output to the new worksheet. You need a control macro that calls the array-creating macro and then calls the output macro for each unused material.
How does the macro recognise an unused material? With the worksheet and the current array, it is not immediately obvious which materials are unused. Is the material described by row 9, for example, used? I would need to look at all the other rows. Only if no other row used row 9’s material would it be unused. I need a new attribute of Type tMaterial:
Type tMaterial
Name As String
Crafted As Boolean
Used As Boolean
Component() As tComponent
End Type
For each material Used would have an initial value of False. As the array was built, any use of the material would be recorded by setting Used to True.
Now to design our main two macros.
The first step of the array-creating macro is to import the worksheet to a Variant. The first data row is 2. You can identify the last used row as 14. The first column is 1. You can identify the last used column as 12. A single statement will load this range to a Variant which creates an array. I will import an extra blank column to give:
| 1 | 2 | 3 | 4| 5 | 6| 7 | 8| 9 |10| 11 |12|13|
--|-------|--------|------|--|----|--|-------|--|-----|--|------|--|--|
1|Bow |Crafted |Wood | 2|Rope| 1|Crystal| 3|Shard| 8|Plumes| 1| |
2|Wood |Crafted |Branch| 2|Leaf| 9| | | | | | | |
3|Rope |Crafted |Web |10| | | | | | | | | |
4|Branch |Crafted |Tree | 1| | | | | | | | | |
5|Crystal|Resource| | | | | | | | | | | |
6|Plumes |Crafted |Bird | 1| | | | | | | | | |
7|Bird |Resource| | | | | | | | | | | |
8|Web |Crafted |Spider| 5| | | | | | | | | |
9|String |Resource| | | | | | | | | | | |
10|Shard |Resource| | | | | | | | | | | |
11|Spider |Resource| | | | | | | | | | | |
12|Leaf |Resource| | | | | | | | | | | |
13|Tree |Resource| | | | | | | | | | | |
I now need to go down each row and check columns 3, 5, 7, 9 and 11. Any material names must be replaced by the relevant row number. Since this is a variant array, I can replace a string value with a numeric value.
For example, in element R1C3, I find “Wood”. I need to look down column 1 for “Wood” which I find in row 2. I set R1C3 to 2 and R2C13 to “U” to indicate wood is used giving:
| 1 | 2 | 3 | 4| 5 | 6| 7 | 8| 9 |10| 11 |12|13|
--|-------|--------|------|--|----|--|-------|--|-----|--|------|--|--|
1|Bow |Crafted | 2| 2|Rope| 1|Crystal| 3|Shard| 8|Plumes| 1| |
2|Wood |Crafted |Branch| 2|Leaf| 9| | | | | | |U |
3|Rope |Crafted |Web |10| | | | | | | | | |
I repeat for R1C5 where I find “Rope”. I look down column 1 for “Rope” which I find in row 3. I set R1C5 to 3 and R3C13 to “U” giving:
| 1 | 2 | 3 | 4| 5 | 6| 7 | 8| 9 |10| 11 |12|13|
--|-------|--------|------|--|----|--|-------|--|-----|--|------|--|--|
1|Bow |Crafted | 2| 2| 3| 1|Crystal| 3|Shard| 8|Plumes| 1| |
2|Wood |Crafted |Branch| 2|Leaf| 9| | | | | | |U |
3|Rope |Crafted |Web |10| | | | | | | | |U |
To transform the original worksheet to the form at the top of this answer (except for column 13), I need:
An outer loop for each row (1 to 13).
An inner loop for each of columns 3, 5 and so on containing a material name.
An inner-inner loop searching the rows for the material name.
I do not need recursion to create this structure. I could use the modified array on this form but I believe it would make the new-worksheet-creating macro easier to understand if the data was moved to an array of Type tMaterial.
As I understand it, there is a specific column of a specific worksheet to which you are to output values. The name of this worksheet, the column letter/number and first row number could be hard-coded into the macro, be defined as constants or be parameters to the macro. I will ignore the worksheet and column but will make row number a parameter of the macro.
For the first row of the macro you may want:
Bow - 1
I first read your question to mean you wanted this row suppressed but I am no longer sure if that was the correct interpretation. No matter; I will explain how this row could be suppressed or made different from the other rows later.
Under this first row you want rows listing the components of Bow:
Bow - 1
>Wood – 2
>Rope – 1
»Crystal – 3
»Shard – 8
>Plumes – 1
I am using “>” to represent indent because I assume the hyphens following the name are real hyphens. The 1, 2, 1, 3, 8 and 1 are quantities.
Under the row for Wood, you want rows listing its components but you want the quantities multiplied by 2, the number of Woods:
Bow - 1
>Wood – 2
>>Branch – 4
>>Leaf – 18
>Rope – 1
>Crystal – 3
>Shard – 8
>Plumes – 1
Branch and Leaf are resources and do not have components but, if they did have components, you would want those components listed under the row for Wood.
This is definitely a requirement for which recursion will be the easiest technique.
The recursive routine (let’s call it OutMatRow) will need a number of parameters:
Materials: the array created by the first macro.
RowMaterial: the row within Materials for the current material.
RowOutput: the row within the output column.
Quantity: the quantity of the current material.
NumIndents: the number of indents for the current material.
I say “parameters” but Materials could be a global variable since OutMatRow does not change this array. RowOutput could also be a global because the source variable is updated each time a row is output. RowMaterial, Quantity and NumIndents MUST be parameters because each call needs its own values for these parameters.
The control routine will call OutMatRow for each unused material. With your demonstration data the only unused material is Bow so the call will be:
Call OutMatRow(Materials, 2, X, 1, 0)
where X represents the number of the first output row.
There will be little code in OutMatRow.
The row for the material must be output. NumIndents, Materials(RowMaterial).Name and Quantity give the values for this row. You can have a different format or suppress output when NumIndents = 0 if you want.
RowOutput must be stepped ready for the next output row.
For each component of a crafted material, the routine will call itself so:
Call OutMatRow(Materials, _
Materials(RowMaterial).Component(N).RowMaterial, _
RowOutput, _
Quantity * _
Materials(RowMaterial).Component(N).Quantity, _
NumIndents + 1)
If you are not familiar with recursive routines, it is a little difficult to understand the sequence in which the calls of OutMatRow occur:
The control macro calls OutMatRowfor Bow.
OutMatRow outputs the row for Bow and calls itself for Bow’s first component which is Wood.
OutMatRow outputs the row for Wood and calls itself for Wood’s first component which is Branch.
OutMatRow outputs the row for Branch. Branch has no components so the routine returns to its caller.
OutMatRow calls itself for Wood’s second component which is Leaf.
OutMatRow outputs the row for Leaf. Leaf has no components so the routine returns to its caller.
Wood has no more components so the routine returns to its caller.
OutMatRow calls itself for Bow’s second component which is Rope.
And so on.
This will be difficult to get your head around. Try with the explanation I have given. If you are still struggling come back with questions and I will attempt a different explanation.
There is a limit of 30,000 characters per answer which I must be close to. There is also value in keeping the first answer separate from the follow on answer(s).
There are some problems with your routine which needed correction. I have gone a little OTT and have made changes for reasons of good practice. I have also added a routine that displays Materials as a check that it is correct. Study my code and try to determine why I have made the changes I have. Come back with questions as necessary.
Option Explicit
Public Type tComponent
RowMaterial As Long
Quantity As Long
End Type
Public Type tMaterial
Name As String
Crafted As Boolean
Used As Boolean
Component() As tComponent
End Type
Sub sFillTypes()
' Constants have two major benefits:
' * Instead of literals your code contains meaningful names making your
' code easier to read.
' * If the value changes, one amendment here fixes the code. For example,
' suppose a new column is added on the left. Looking through the code
' deciding which 2s, 3s and 4s are to be changed to 3s, 4s and 5s is
' nightmare.
' Variable names should be meaningful. Reading code full of Ks, Xs and Ys
' is difficult because the reader has to remember what they are. My system
' is to use a sequence of words or abbreviations. The first word says what
' I am using the variable for: Col=column number, Row=row number, etc.
' Each additional word reduces the scope until I have a unique name. I do
' not know the name of your worksheet so I have used Sht as the second word
' of variables that relate to the worksheet. Crnt (=current), First and Last
' are common words in my names. I can look at routines I wrote 10 years ago
' and immediately know what all the variables are which is a real help when
' trying to update them. If you do not like my system, develop your own.
Const ColShtItem As Long = 1
Const ColShtType As Long = 2
Const ColShtMatFirst As Long = 3
Const RowShtDataFirst As Long = 2
Dim ColShtCrnt As Long
Dim ColShtLast As Long
Dim ColShtMatLast As Long
Dim ColShtUsed As Long
Dim Found As Boolean
Dim InxComp As Long
Dim Materials() As tMaterial
Dim RowShtCrnt As Long
Dim RowShtItem As Long
Dim RowShtLast As Long
Dim ValuesSht As Variant
With ActiveSheet
' Cell.End is a convenient way of finding the last used cell in a row or column.
' It is probably a reliable way of finding the last row of your worksheet but you
' are relying on row 1 having a complete set of headers to determine the last column
' which makes me uncomfortable.
RowShtLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
ColShtLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
' I do not know what you are doing with Count but this code cannot be at the top. Each
' row will have its own number of materials
' * This statements loads the values of the range to ValuesSht as an array.
' * I have loaded the first data row to the last row because I do not want the
' header row. I have loaded column 1 to last column plus 1 because I want an extra,
' blank column on the left.
' * ValuesSht will become a 2D array with the first dimension being for rows and the
' second for columns.
' * The top left cell of ValuesSht will always be (1,1) even if the range does not
' start in cell (1,1).
ValuesSht = .Range(Cells(RowShtDataFirst, 1), .Cells(RowShtLast, ColShtLast + 1))
End With
ReDim Materials(1 To UBound(ValuesSht, 1))
' I will use the RowSht variables for ValuesSht even though the worksheet and array
' rows do not match because I have finished with the worksheet. The worksheet and
' array columns match so I will use the ColSht variables for both.
' I will also use the RowSht variables for Materials since the rows match.
ColShtUsed = ColShtLast + 1 ' I load an extra column to hold used values
For RowShtCrnt = 1 To UBound(ValuesSht, 1)
' Copy across the non-repeating values
Materials(RowShtCrnt).Name = Trim(ValuesSht(RowShtCrnt, ColShtItem))
Select Case LCase(Trim(ValuesSht(RowShtCrnt, ColShtType)))
Case "crafted"
Materials(RowShtCrnt).Crafted = True
Case "resource"
Materials(RowShtCrnt).Crafted = False
Case Else
' Do not assume the worksheet is perfect.
Call MsgBox("Cell B" & RowShtCrnt + RowShtDataFirst - 1 & _
" does nor contain ""Crafted"" or ""Resource""", vbOKOnly)
Exit Sub
End Select
' If materials are not always below the item that uses them, this block
' will have to be in its own loop after the rest of Materials has been created
If ValuesSht(RowShtCrnt, ColShtUsed) = "U" Then
Materials(RowShtCrnt).Used = True
Else
Materials(RowShtCrnt).Used = False
End If
If Materials(RowShtCrnt).Crafted Then
' Replace material names in columns ColShtMatFirst, ColShtMatFirst+2 and so on
' with the number of the row for the material.
' Loop over all possible material columns
For ColShtCrnt = ColShtMatFirst To ColShtLast - 1 Step 2
If Trim(ValuesSht(RowShtCrnt, ColShtCrnt)) = "" Then
ColShtMatLast = ColShtCrnt - 2
Exit For
End If
' Look down the remainder of ValuesSht for this material.
' This relies on used materials always being below the material they are
' used to make. This is a easy way of (1) preventing loops and (2) ensuring
' the used column is ready when required. If materials are not in this
' sequence, you will need a more sophisticated method of detecting loops such
' as: Material1 used to make Material2, Material2 used to make Material3 and
' Material3 used to make Material1.
Found = False
For RowShtItem = RowShtCrnt + 1 To UBound(ValuesSht, 1)
If Trim(ValuesSht(RowShtItem, ColShtItem)) = _
Trim(ValuesSht(RowShtCrnt, ColShtCrnt)) Then
ValuesSht(RowShtCrnt, ColShtCrnt) = RowShtItem
Found = True
Exit For
End If
Next RowShtItem
If Not Found Then
Call MsgBox("I cannot find the material in cell " & _
ColNumToCode(ColShtCrnt) & RowShtCrnt + RowShtDataFirst - 1 & _
" (" & ValuesSht(RowShtCrnt, ColShtCrnt) & ") defined on rows " & _
RowShtCrnt + 2 & " to " & UBound(ValuesSht, 1) + 1, vbOKOnly)
Exit Sub
End If
ValuesSht(RowShtItem, ColShtUsed) = "U" ' Record this item used
Next ColShtCrnt
' For the current row, the material names in columns ColShtMatFirst, ColShtMatFirst+2
' and so on have been replaced by row numbers. ColShtMatLast has been set as
' appropriate for this row.
' Size Components as required for this material and move component detals for ValuesSht
ReDim Materials(RowShtCrnt).Component(1 To (ColShtMatLast - ColShtMatFirst) / 2 + 1)
InxComp = 1
For ColShtCrnt = ColShtMatFirst To ColShtMatLast Step 2
Materials(RowShtCrnt).Component(InxComp).RowMaterial = ValuesSht(RowShtCrnt, ColShtCrnt)
Materials(RowShtCrnt).Component(InxComp).Quantity = ValuesSht(RowShtCrnt, ColShtCrnt + 1)
InxComp = InxComp + 1
Next
End If ' Materials(RowShtCrnt).Crafted
Next RowShtCrnt
' Delete or comment out this line when you are satified the above code is correct.
Call ListMaterials(Materials)
End Sub
Sub ListMaterials(ByRef Materials() As tMaterial)
' Debug.Print is very useful when debugging code. The only downside is that the
' Immediate Window will only hold 200 or so lines. After that, line at the top
' get lost. If I have or expect too many lines for the Immediate Window, I use
' a text file.
Dim InxComp As Long
Dim InxMat As Long
Dim InxMatUsed As Long
Dim LenMatNameMax As Long
Dim Name As String
Dim NumCompMax As Long
' Determine maximum length of a material name and the maximum number of
' components so the output can be formatted nicely.
LenMatNameMax = 0
NumCompMax = 0
For InxMat = LBound(Materials) To UBound(Materials)
If LenMatNameMax < Len(Materials(InxMat).Name) Then
LenMatNameMax = Len(Materials(InxMat).Name)
End If
If Materials(InxMat).Crafted Then
If NumCompMax < UBound(Materials(InxMat).Component) Then
NumCompMax = UBound(Materials(InxMat).Component)
End If
End If
Next InxMat
' List Materials and their components
' Output header line
Debug.Print Left("Name" & Space(LenMatNameMax), LenMatNameMax) & " T U |";
For InxComp = 1 To NumCompMax
Debug.Print Left("Material" & Space(LenMatNameMax), LenMatNameMax) & " Qty|";
Next
Debug.Print
' Output materials
For InxMat = LBound(Materials) To UBound(Materials)
Debug.Print Left(Materials(InxMat).Name & Space(LenMatNameMax), LenMatNameMax + 1) & _
IIf(Materials(InxMat).Crafted, "C ", "R ") & _
IIf(Materials(InxMat).Used, "Y ", " ") & "|";
If Materials(InxMat).Crafted Then
For InxComp = 1 To UBound(Materials(InxMat).Component)
Name = Materials(Materials(InxMat).Component(InxComp).RowMaterial).Name
Debug.Print Left(Name & Space(LenMatNameMax), LenMatNameMax + 1) & _
Right(" " & Materials(InxMat).Component(InxComp).Quantity, 3) & "|";
Next
End If
Debug.Print
Next InxMat
End Sub
Function ColNumToCode(ByVal ColNum As Long) As String
' Last updated 3 Feb 12. Adapted to handle three character codes.
Dim ColCode As String
Dim PartNum As Long
If ColNum = 0 Then
ColNumToCode = "0"
Else
ColCode = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
ColCode = Chr(65 + PartNum) & ColCode
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
ColNumToCode = ColCode
End Function