I recently wrote a question asking for help on how to count the number of occurrences of each and every unique pair of allergies within a population. The solutions I got were great, however I now need to look at combinations of 3+ allergies, and doing it all using Excel tables will take forever.
I decided to write a VBA script to do this, which works great for pairs. It's also much faster since I went back and changed the format of the source data so that each ExceptionID's associated AllergenID's are stored in a single comma-delimited string.
I'm now looking at moving up to a 3D or higher array, and because we don't know how many dimensions we might need to go up to (potentially 10 or 15) I would rather avoid using a series of Case or nested If/Then statements.
My research turned up this article in which I gather that what I'm asking is practically impossible, but I wanted to ask about that OP's statement that
I was thinking it would be possible to do if I could construct the Redim statement at runtime as a string and execute the string, but this doesn't seem possible.
I basically had the same idea. The code below generates a Type Mismatch error, but is there no variation of this that might work? Can we not pass other functions (like join) inside ReDim?
Sub testroutine()
Dim x As Integer, y As Integer 'just a counter
Dim PairCount() As String
Dim AllergenRef As Object 'Object to store a reference to each AllergenID using AllergenKey as key
Set AllergenRef = CreateObject("Scripting.Dictionary")
For x = 1 To 20
AllergenRef.Add x, (x * 10) + (2 ^ x) 'dummy data for my dictionary
Next x
Dim N_tuple As Integer
N_tuple = 5 'this value would be provided by a user form at runtime
Dim ArrayDim() As String
ReDim ArrayDim(1 To N_tuple)
For x = 1 To N_tuple
ArrayDim(x) = "1 to " & AllergenRef.Count
Next x
ReDim PairCount(Join(ArrayDim, ",")) 'This is the line that throws an error
End Sub
This article makes it sound like what I'm doing is possible in Java, but I don't speak any Javanese so I can't really tell how similar this is to what I'm trying to achieve, or if there's a way to apply this method to VBA...
========UPDATE============
Here is a sample of the data I'm working with (in separate columns, I added dashes for clarity)
ExceptionID - ExcAllergens
035 - 100380
076 - 100107,100392,100345,100596,100141,100151,100344
200 - 100123,100200
325 - 100381
354 - 100381,100123
355 - 100381,100123
360 - 100586
390 - 100151,100344,100345,100349
441 - 100380,100368
448 - 100021,100181,100345,100200,100344,100295
491 - 100381
499 - 100333
503 - 100333
507 - 100331,100346,100596,100345,100344,100269,100283
And here is an extract from the Allergen definitions table (Allergen Key is something I just added so as to have smaller numbers to work with, the 6 digit numbers are what is used in our DB.)
AllergenKey - AllergenID - AllergenTag
01 - 100011 - Açai Berry
02 - 100012 - Acetic Acid
03 - 100013 - Agar Agar
04 - 100014 - Agave
05 - 100015 - Alcohol
06 - 100016 - Allspice
07 - 100017 - Ammonium Bicarbonate
08 - 100018 - Amylase
09 - 100019 - Annatto
10 - 100020 - Apple
11 - 100021 - Apple, Raw
12 - 100022 - Apricot
13 - 100023 - Arrowroot
14 - 100025 - Ascorbic Acid
15 - 100027 - Asparagus
16 - 100028 - Avocado
17 - 100029 - Bacterial Culture
18 - 100030 - Baking Powder
Note that there are 6810 exception profiles ranging from 1 to 51 separate allergies (around 4 or 5 on average), and 451 different allergens. Here is the result from my analysis of allergen pairs (btw when I say "Allergen" it also includes dietary preferences like vegetarian):
Top 10 pairs - Pair Count - Allergen 1 - Allergen 2
1 - 245 - Dairy - Gluten
2 - 232 - Eggs - Nuts
3 - 190 - Dairy - Eggs
4 - 173 - Gluten - Oats
5 - 146 - Soy (May Contain) - Soy
6 - 141 - Dairy - Nuts
7 - 136 - Beef - Pork
8 - 120 - Dairy - Soy
9 - 114 - Sesame (May Contain) - Nuts
10 - 111 - Vegetarian 1 - Pork
I wouldnt' worry about the max possible combinations with your medium-sized dataset. You wont be able to make all the possible combinations. You will have many combinations that will not occur in the sample population. Do not try and calculate them all, and then count the occurrences.
Instead, work through your sample population, and create the tuples as data entries on the worksheet 'array'. I suggest using the 3-digit allergen key as identifier numbers, and combine the numbers in tuples a Long(perhaps Decimal may be needed for larger numbers).
The approach I suggest is to combine the tuples as longs which can be easily be decomposed later. Then use the frequency function to count the occurrences of each tuple 'number'. so if there are allergens with keys: 1, 17, 451 - they form a composed long of 1,017,451 (identical to 451, 17, & 1)- we ensure that any tuple has forced order of smallest key to largest key. So the max triple is 449,450,451, and the smallest is 1,002,003. Note that you can NEVER have 3,002,001 as that would duplicate 1,002,003.
The module I had a play with is below:
EDIT - for better code
Option Explicit
Option Base 1
Public Function concID(paramArr() As Variant) As Variant
' this function takes an array of numbers and arranges the array into
' one long code number - with order of smallest to largest
' the code number generated has each individual array entry as a 3-digit component
Dim wsf As WorksheetFunction
Dim decExp As Integer
Dim i As Long, j As Long
Dim bigNum As Variant ' may need to cast to Decimal??
Set wsf = WorksheetFunction
'may use cDec if necessary here??
For i = 1 To UBound(paramArr)
'determine the position of the component by multiplying by a multiple of 10^3
decExp = 3 * (UBound(paramArr) - i)
bigNum = bigNum + wsf.Small(paramArr, i) * 10 ^ decExp
Next i
concID = bigNum
End Function
Public Sub runAllergen()
Dim ws As Worksheet
Dim dataRange As Range, tupleRange As Range, uniqueList As Range, freqRange As Range, r As Range
Dim i As Long, j As Long, counter As Long
Dim dataArray As Variant, arr As Variant, tempholder As Long
Dim bigArray(1 To 10 ^ 6, 1 To 1) As Variant ' the array which will hold all the generated combinations from the data
Dim tuple As Long
tuple = 3
'this will come in as a user input.
Set ws = Sheet1
Set dataRange = ws.Range("A2:A10001") 'I have 10k people in my dataset, and this is just the allergen data vector
Application.ScreenUpdating = False 'IMPORTANT for efficiency
tempholder = 1 'this is the array index which the next combi entry is to be put into bigArray
dataArray = dataRange.Value 'write entire worksheet column to internal array for efficiency
For i = 1 To UBound(dataArray)
'obtain array of allergen values in each data row to obtain tuples from
arr = Split(dataArray(i, 1), ",")
If UBound(arr) + 1 >= tuple Then
'give over the array of row data to make tuples from and write to bigArray
'return the next available index of bigArray to store data
tempholder = printCombinations(arr, tuple, bigArray(), tempholder)
End If
Next i
Set r = ws.Range("B2")
'write entire list of tuples from data population to worksheet for efficiency - MASSIVE performance boost
r.Resize(tempholder - 1, 1).Value = bigArray
'copy tuple output over to another column to remove duplicates and get unique list
Set tupleRange = ws.Range(r, r.End(xlDown))
tupleRange.Copy
Set r = ws.Range("D2")
r.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'remove duplicates from copied tuple output to get a unique list of codes to serve as bins in FREQUENCY function
ws.Range(r, r.End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
Set uniqueList = ws.Range(r, r.End(xlDown))
Application.CutCopyMode = False
'set the frquency output range which is always 1 more row than the bins array
Set freqRange = uniqueList.Offset(0, 1).Resize(uniqueList.Rows.Count + 1, 1)
'get the frequency of each tuple
freqRange.FormulaArray = "=FREQUENCY(R2C" & tupleRange.Column & ":R" & tupleRange.Rows.Count + 1 & _
"C" & tupleRange.Column & _
",R2C" & uniqueList.Column & ":R" & uniqueList.Rows.Count + 1 & "C" & uniqueList.Column & ")"
Application.ScreenUpdating = True
End Sub
Public Function printCombinations(pool As Variant, r As Long, printVector As Variant, tempPosition As Long) As Long
'this function writes the data row arrays as tuples/combis to the bigArray,
'and returns the next available index in bigArray
Dim i As Long, j As Long, n As Long
Dim tempholder() As Variant
Dim idx() As Long
ReDim tempholder(1 To r)
ReDim idx(1 To r)
n = UBound(pool) - LBound(pool) + 1
For i = 1 To r
idx(i) = i
Next i
Do
For j = 1 To r
tempholder(j) = CLng(pool(idx(j) - 1))
Next j
'we now have an array of size tuple from the row data, so construct our code number,
'and write to the next available index in bigArray
printVector(tempPosition, 1) = concID(tempholder)
tempPosition = tempPosition + 1
' Locate last non-max index
i = r
While (idx(i) = n - r + i)
i = i - 1
If i = 0 Then
'the algorithm has ended with the last index exhausted
'return the next available index of bigArray
printCombinations = tempPosition
Exit Function
End If
Wend
idx(i) = idx(i) + 1
For j = i + 1 To r
idx(j) = idx(i) + j - i
Next j
Loop
End Function
Initial set-up:
You could also copy-paste over your frequency Range into values etc....
To expand on my comment, here is some modified code to use an array of arrays based on the provided N_tuple variable. I am having a difficult time imagining a scenario where this wouldn't work for you:
Sub testroutine()
Dim x As Integer, y As Integer 'just a counter
Dim ArrayTemp() As Variant
Dim PairCount() As Variant
Dim AllergenRef As Object 'Object to store a reference to each AllergenID using AllergenKey as key
Set AllergenRef = CreateObject("Scripting.Dictionary")
For x = 1 To 20
AllergenRef.Add x, (x * 10) + (2 ^ x) 'dummy data for my dictionary
Next x
Dim N_tuple As Integer
N_tuple = 5 'this value would be provided by a user form at runtime
'Now that you have your N_tuple, redim your paircount array
ReDim PairCount(1 To N_tuple)
'For each N_tuple, create an array and add it to the PairCount array
'Note that you could easily have a 2-dimensional array for a table of values as ArrayTemp
For x = 1 To N_tuple
ReDim ArrayTemp(1 To AllergenRef.Count)
PairCount(x) = ArrayTemp
Next x
'Now you have an array of arrays, which can be easily accessed.
'For example: PairCount(2)(3)
'Or if the subarrays are 2-dimensional: PairCount(4)(6, 12)
'This simply loops through the PairCount array and shows the ubound of its subarrays
For x = 1 To UBound(PairCount)
MsgBox UBound(PairCount(x))
Next x
End Sub
Related
i try to create an array and fill it with unique values.
Due to check if the value is unique, i fail to create a basic "for each" procedure.
I just want to create a unique random number, put it into an array, create another unique random number an put it into the same array.
If fail into search about that topic and failed to google that problem, therefore i have to ask the community at stackoverlofw.
I dont have any valuable code because nothing worked.
I only have an google code which worked for me in cells at excel, but not in array.
For Each Cell In Selection.Cells
Do
rndNumber = Int((High - Low + 1) * Rnd() + Low)
Loop Until Selection.Cells.Find(rndNumber, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing
Cell.Value = rndNumber
Next
Hopefully
Option Explicit
Function GetRandomsArray(ByVal n As Long, Low As Long, High As Long)
Dim rndNumber As Long
If High - Low + 1 < n Then n = High - Low + 1
With CreateObject("Scripting.Dictionary")
Do
rndNumber = Int((High - Low + 1) * Rnd() + Low)
.Item(rndNumber) = 1
Loop While .Count < n
GetRandomsArray = .Keys
End With
End Function
To be used in a "Main" sub as follows:
Dim myArray As Variant
myArray = GetRandomsArray(5, 1, 10) '<--| get an array of 5 unique random numbers between 1 and 10
In Excel, I have a list of items with their weight. I've made a function in VBA which picks random items out of the list as long as the total weight is under 10.
Before this function I made an array of only zero's which should belong each to an item. When the random function picks an item, this place in the array should change into an one, but this part of the function doesn't work.
Can anyone help me to solve this problem/repair the function?
This is my code:
Sub Test()
Dim weight As Single, totWeight As Single
Dim finish As Boolean
Dim r As Integer
Const maxWeight = 10
'Here it makes an array of only zero's
Dim Arr(1 To 66) As String, i As Integer
For r = 1 To 66
Arr(r) = 0
Next r
Do Until finish = True
'Pick random row out of my Excel sheet
r = Int((65 * Rnd()) + 2)
'The first are the titles (item, weight), so that's why I start from row 2
If (totWeight + Cells(r, 2)) < maxWeight Then
'Sum the picked weight up to the total weight
totWeight = totWeight + Cells(r, 2)
'Change the position of the item in the array into a 1
'But it doesn't work
--> Arr(r) = 1
Else
'Do as long as the weight is under 10
finish = True
End If
Loop
'It only prints zero's
PrintArray Arr, ActiveWorkbook.Worksheets("Sheet1").[F1]
End Sub
(btw, this is the print function:
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1)) = Data
End Sub)
I debuged your code, and it seems that problem is in your print function. Try this one
Sub PrintArray(Data As Variant, Cl As Range)
Dim i As Integer
For i = LBound(Data) To UBound(Data)
Cl.Cells(i, 1).Value = Data(i)
Next i
End Sub
If you are interested why your solution didnt work, i think its because you tried to assign array into value. So always when need to copy array, do it item by item...
The reason it seemed like you were not putting ones into the array is because the array was oriented backwards to the way you were dumping the array elements' values back into the worksheet. Essentially, you were filling all 66 cells with the value from the first element (e.g. arr(1)). If you did this enough times, sooner or later the random r var would come out as 1 and the first element of the array would receive a 1. In this case, all of the cells would be ones.
With your single dimension array, you can use the Excel Application object's TRANSPOSE function to flip your array from what is essentially 1 row × 66 columns into 66 rows × 1 column.
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data)) = Application.Transpose(Data)
End Sub
That is a bit of a bandaid fix and the Application.Transpose has some limits (somewhere around an unsigned int - 1).
If you are creating an array for the end purpose of populating an range of cells on a worksheet, start with a 2 dimensioned array and stick with it. Keep the rank of the array correct and you won't have any problems dumping the values back into the worksheet.
Sub Test()
Dim weight As Single, totWeight As Single
Dim r As Long
Const maxWeight = 10
'Here it makes an array of only zero's
Dim Arr(1 To 66, 1 To 1) As String, i As Integer
For r = LBound(Arr, 1) To UBound(Arr, 1)
Arr(r, 1) = 0
Next r
With ActiveWorkbook.Worksheets("Sheet1")
Do While True
'Pick random row out of my Excel sheet
r = Int((65 * Rnd()) + 2)
'The first are the titles (item, weight), so that's why I start from row 2
If (totWeight + .Cells(r, 2)) < maxWeight Then
'Sum the picked weight up to the total weight
totWeight = totWeight + .Cells(r, 2)
'Change the position of the item in the array into a 1
Arr(r, 1) = 1 '<~~
Else
'just exit - no need to set a boolean
Exit Do
End If
Loop
PrintArray Arr, .Range("F2")
End With
End Sub
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub
This won't make much difference with 66 rows but with respect to Luboš Suk and his excellent answer, looping through 100K cells to stuff arrayed values back into a worksheet is pretty slow by array standards and we use arrays on reasonably large data blocks because they are faster. Dumping the values back en masse is almost instantaneous.
I'm a little bit familiar with VBA Excel 2013. My problem now is, that I need to sum the values where specific Strings are available.
I need to calculate within a column only the values where a lookup is true.
My table looks like:
9 | AD,DCO,PD
5 | AD
5 | PD
15 | PD
So the sum for AD would be 14 or DCO would be 9 or PD would be 29 an therefore the result table have to look like this:
AD | DCO | PD
—–—–—–—–—–––—–
14 | 9 | 29
Can anybody help me?
Forget VBA. Sumproduct solves this perfectly.
I'm assuming that your commas separate cells, so Column A has the numbers, then columns B-D have the letters. If they do not, you can always use the Text to Columns function in excel (look under the Data tab) to make this so.
Put the following function where you wnat the answer (say, B10):
=SUMPRODUCT(($A$1:$A$4) * ($B$1:$D$4 = $A$10))
You can then type in cell A10 the code letter and it will sum up column A, where columns B-D contain that text.
If you want to display all text options, you can make a list of them (say A10 = AD, A11 = DCO, A12 = PD), then in B10 put the same formula as above but remove the $ from in front of the number (so it reads $A10). You can then drag it down and it will tally up for each of the values in A10-A13 and display the results in B10 - B13.
If I have correctly interpreted your sample data into a pseudo-table then the native SUMIF function will conditionally sum the numbers in column A using a wildcard criteria against column B. Example in D2 (as the image below) would be =SUMIF($B$1:$B$4,"*"&D$1&"*",$A$1:$A$4).
Fill or copy right as necessary. The caution is that wildcards may make false positives when the criteria closely resembles other values. This is not the case with your sample data.
Problem Solved, but do you have any suggestion to speed up the code?
Sub Calculate()
Dim Dict As Object
Dim i As Long
Dim e As Long
Set Dict = CreateObject("Scripting.Dictionary")
Dim b, m As Long
Dim a As Long
Dim c As Variant
Dim j As Long
Dim sum_Dict As Variant
Dim column_Dict As Variant
i = 1
e = 16
a = i
a = a - 2
For i = i To e
For Each sum_Dict In Range("A" & i & ":" & "A" & e) 'Spalte V = Price
If sum_Dict = "" Then
i = i + 1
Else
For Each c In Range("B" & i & ":F" & i) 'All Columns from B til F
' iterating over the array
For j = LBound(column_Dict) To UBound(column_Dict)
' assigning the separated values to columns
b = CDbl(sum_Dict) 'convert to double
c = CStr(c) 'convert to string
If Dict.Exists(c) Then 'check if key exists
Dict.Item(c) = Dict.Item(c) + b 'if key exists sum the items
Else 'if the key does not exist create it
Dict.Add Key:=c, Item:=b
End If
Next j
Next c
i = i + 1
'extract keys into variant array
'Debug.Print "Array of Keys and items"
For m = 0 To Dict.Count - 1
'Debug.Print Dict.Keys()(m), Dict.Items()(m)
Next m
'Debug.Print Dict.Count & " Items in Dictionary"
End If
Next sum_Dict
Next
'-- output to sheet using first 1D Array
Range("H" & a + 2).Resize(1, _
UBound(Application.Transpose(Dict.Keys()))) = Dict.Keys()
'-- output to sheet using dictionary
Range("H" & a + 3).Resize(1, _
UBound(Application.Transpose(Dict.Items()))) = Dict.Items()
Dict.RemoveAll ' empty dictionary
End Sub
Background: I'm pulling all of the field names from a database into an array - I've got this part done without a problem, so I already have an array containing all the fields (allfields()) and I have a count of how many fields there are (numfields).
I am now trying to compile all of the unique combinations that can be made from those various field names. For example, if my three fields are NAME, DESCR, DATE, I would want to return the following:
NAME, DESCR, DATE
NAME, DESCR
NAME, DATE
DESCR, DATE
NAME
DESCR
DATE
I've tried a few different things for this, including multiple nested loops, and modifying the answer here: How to make all possible sum combinations from array elements in VB to fit my needs, but it appears as though I do not have access to the necessary libaries (System or System.Collections.Generic) on my work PC, as it only has VBA.
Does anyone have a bit of VB code kicking around that would fulfill this purpose?
Thanks a lot!
I had a similar requirement some years ago. I do not remember why and I no longer have the code but I do remember the algorithm. For me this was a one-off exercise so I wanted an easy code. I did not care about efficiency.
I will assume one-based arrays because it makes for a marginally easier explanation. Since VBA supports one-based arrays, this should be OK although it is an easy adjustment to zero-based arrays if that is what you want.
AllFields(1 To NumFields) holds the names.
Have a Loop: For Inx = 1 To 2^NumFields - 1
Within the loop consider Inx as a binary number with bits numbered 1 to NumFields. For each N between 1 and NumFields, if bit N is one include AllFields(N) in this combination.
This loop generates the 2^NumFields - 1 combinations:
Names: A B C
Inx: 001 010 011 100 101 110 111
CombinationS: C B BC A A C AB ABC
The only difficulty with VBA is getting the value of Bit N.
Extra section
With everyone having at go at implementing bits of my algorithm, I thought I had better show how I would have done it.
I have filled an array of test data with an nasty set of field names since we have not been told what characters might be in a name.
The subroutine GenerateCombinations does the business. I am a fan of recursion but I do not think my algorithm is complicated enough to justify its use in this case. I return the result in a jagged array which I prefer to concatenation. The output of GenerateCombinations is output to the immediate window to demonstrate its output.
Option Explicit
This routine demonstrates GenerateCombinations
Sub Test()
Dim InxComb As Integer
Dim InxResult As Integer
Dim TestData() As Variant
Dim Result() As Variant
TestData = Array("A A", "B,B", "C|C", "D;D", "E:E", "F.F", "G/G")
Call GenerateCombinations(TestData, Result)
For InxResult = 0 To UBound(Result)
Debug.Print Right(" " & InxResult + 1, 3) & " ";
For InxComb = 0 To UBound(Result(InxResult))
Debug.Print "[" & Result(InxResult)(InxComb) & "] ";
Next
Debug.Print
Next
End Sub
GenerateCombinations does the business.
Sub GenerateCombinations(ByRef AllFields() As Variant, _
ByRef Result() As Variant)
Dim InxResultCrnt As Integer
Dim InxField As Integer
Dim InxResult As Integer
Dim I As Integer
Dim NumFields As Integer
Dim Powers() As Integer
Dim ResultCrnt() As String
NumFields = UBound(AllFields) - LBound(AllFields) + 1
ReDim Result(0 To 2 ^ NumFields - 2) ' one entry per combination
ReDim Powers(0 To NumFields - 1) ' one entry per field name
' Generate powers used for extracting bits from InxResult
For InxField = 0 To NumFields - 1
Powers(InxField) = 2 ^ InxField
Next
For InxResult = 0 To 2 ^ NumFields - 2
' Size ResultCrnt to the max number of fields per combination
' Build this loop's combination in ResultCrnt
ReDim ResultCrnt(0 To NumFields - 1)
InxResultCrnt = -1
For InxField = 0 To NumFields - 1
If ((InxResult + 1) And Powers(InxField)) <> 0 Then
' This field required in this combination
InxResultCrnt = InxResultCrnt + 1
ResultCrnt(InxResultCrnt) = AllFields(InxField)
End If
Next
' Discard unused trailing entries
ReDim Preserve ResultCrnt(0 To InxResultCrnt)
' Store this loop's combination in return array
Result(InxResult) = ResultCrnt
Next
End Sub
Here's some code that will do what you want. It assigns a zero or one to each element and joins up the elements that are assigned a one. With four elements, for example, you have 2^4 combinations. Represented as zeros and ones, it would look like
0000
0001
0010
0100
1000
0011
0101
1001
0110
1010
1100
0111
1011
1101
1110
1111
This code creates an array(maInclude) that replicates all 16 of those scenarios and uses the corresponding mvArr element to concatenate the results.
Option Explicit
Dim mvArr As Variant
Dim maResult() As String
Dim maInclude() As Long
Dim mlElementCount As Long
Dim mlResultCount As Long
Sub AllCombos()
Dim i As Long
'Initialize arrays and variables
Erase maInclude
Erase maResult
mlResultCount = 0
'Create array of possible substrings
mvArr = Array("NAME", "DESC", "DATE", "ACCOUNT")
'Initialize variables based on size of array
mlElementCount = UBound(mvArr)
ReDim maInclude(LBound(mvArr) To UBound(mvArr))
ReDim maResult(1 To 2 ^ (mlElementCount + 1))
'Call the recursive function for the first time
Eval 0
'Print the results to the immediate window
For i = LBound(maResult) To UBound(maResult)
Debug.Print i, maResult(i)
Next i
End Sub
Sub Eval(ByVal lPosition As Long)
Dim sConcat As String
Dim i As Long
If lPosition <= mlElementCount Then
'set the position to zero (don't include) and recurse
maInclude(lPosition) = 0
Eval lPosition + 1
'set the position to one (include) and recurse
maInclude(lPosition) = 1
Eval lPosition + 1
Else
'once lPosition exceeds the number of elements in the array
'concatenate all the substrings that have a corresponding 1
'in maInclude and store in results array
mlResultCount = mlResultCount + 1
For i = 0 To UBound(maInclude)
If maInclude(i) = 1 Then
sConcat = sConcat & mvArr(i) & Space(1)
End If
Next i
sConcat = Trim(sConcat)
maResult(mlResultCount) = sConcat
End If
End Sub
Recursion makes my head hurt, but it sure is powerful. This code was adapted from Naishad Rajani whose original code can be found at http://www.dailydoseofexcel.com/archives/2005/10/27/which-numbers-sum-to-target/
to build on Tony's answer:
(where A = 4, B = 2, C = 1)
(the following is pseudocode)
If (A And Inx <> 0) then
A = True
end if
I am trying to program a simple loop to run through the user selected values and filter out some number display and the numbers I want in a different column.
I have 10 random numbers in a column in this order:
3
7
10
12
5
2
7
13
9
23
I essentially want to ignore the first value, retrieve the next two values, skip the fourth
value, retrieve the next two values and so on. So my output would be:
7
10
5
2
13
9
All I have is a loop that runs through the column. I think I would have to use the mod() function but I can't sem to get it right. All I have so far is this empty loop:
Sub findValues()
Do While Cells(x, 3).Value <> "" 'go through values in column 3 until empty cell is encountered
'skip first value
'retrieve next two values and put them in different column
'...
Loop
End Sub
Here's one solution to do it using a loop and Step 3.
It's not the fastest or optimized way, but it's one of many methods that works and this method is rather simplistic. The example assumes that the data is in column A and the new list will be output to column B.
Since you want to skip the first value, I start the loop at A2, then do a Step 3 each loop (but copy over 2 elements, so it'll always skip the 3rd element).
Sub test()
Application.ScreenUpdating = False
Dim i As Long, j As Long
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
j = 1
For i = 2 To lastRow Step 3
Cells(j, 2).Value = Cells(i, 1).Value
Cells(j + 1, 2).Value = Cells(i + 1, 1).Value
j = j + 2
Next
Application.ScreenUpdating = True
End Sub
Note that using Cells(row, column) is better for looping than Range() notation (and faster, too).
[Update: formula solution]
enter this in D1 and copy down 2/3 the length of your C column
=IF(MOD(ROW(),2)=1,OFFSET($C$1,INT(ROW()/2)*3+1,0),OFFSET($C$1,INT(ROW()/2)*3-1,0))
[initial post]
I've used a variant array as its more efficient (albeit slightly more complex) than a loop
In short what you were looking for is a Mod function where
(Row-1) Mod 3 = 0
should be excluded
ie exclude position 1,4,7 etc
This code dumps the output from column C to D. It will cater for as many values that exist in C (note I have set the c range by looking up from bottom not down from top, so blanks wont through the code out)
Sub GetValues()
Dim rng1 As Range
Dim lngCnt As Long
Dim lngCnt2 As Long
Dim X
Dim Y
Set rng1 = Range([c1], Cells(Rows.Count, "C").End(xlUp))
X = rng1
ReDim Y(1 To 2 / 3 * rng1.Cells.Count, 1 To 1)
For lngCnt = 1 To UBound(X, 1)
If (lngCnt - 1) Mod 3 <> 0 Then
lngCnt2 = lngCnt2 + 1
Y(lngCnt2, 1) = X(lngCnt, 1)
End If
Next
[d1].Resize(UBound(Y, 1), 1) = Y
End Sub]