Trying to check column one for a value (column in the multidimensional array that is) and if it matches sort another column for the value that matches that row.
I think I am doing this wrong, but this is the first time I am messing with multidimensional arrays.
Would I need to use UBound and LBound in each for loop to tell it what colum to look through?
I am def interested in learning the best practice method for using this in the future, aside from just an answer/solution tot he current issue.
Code:
Private Sub ThisStuff()
Dim CoaAmt As Long
Dim COAArray(3, 2)
Dim ThisValue As String
Dim AnotherValue As String
AnotherValue = "Bananas"
ThisValue = "Apples"
COAArray(0, 0) = "Apples"
COAArray(1, 0) = "Oranges"
COAArray(2, 0) = "Peaches"
COAArray(3, 0) = "Pomegranets"
COAArray(0, 1) = 498
COAArray(0, 1) = 505
COAArray(1, 1) = 564
COAArray(1, 2) = 556
COAArray(2, 1) = 570
COAArray(2, 2) = 573
COAArray(3, 1) = 742
COAArray(3, 2) = 750
If AnotherValue = "Bananas" Then
For i = COAArray(0, 0) To COAArray(3, 0)
For j = COAArray(1, 0) To COAArray(3, 2)
If COAArray(i, j) = ThisValue Then CoaAmt = COAArray(i, j)
Next j
Next i
End If
MsgBox ("The value of CoaAmt is " & CoaAmt)
End Sub
Yes. The LBound and
UBound functions allow you to specify the rank. This lets your nested For .. Next loops to cycle through all array elements.
debug.print LBound(COAArray, 1) & ":" & UBound(COAArray, 1)
debug.print LBound(COAArray, 2) & ":" & UBound(COAArray, 2)
If AnotherValue = "Bananas" Then
For i = LBound(COAArray, 1) To UBound(COAArray, 1)
For j = LBound(COAArray, 2) To UBound(COAArray, 2)
If COAArray(i, j) = ThisValue Then CoaAmt = COAArray(i, j)
Next j
Next i
End If
Your array element assignment was a little messed up. It should have been closer to,
COAArray(0, 0) = "Apples"
COAArray(1, 0) = "Oranges"
COAArray(2, 0) = "Peaches"
COAArray(3, 0) = "Pomegranates"
COAArray(0, 1) = 498
COAArray(1, 1) = 505
COAArray(2, 1) = 564
COAArray(3, 1) = 556
COAArray(0, 2) = 570
COAArray(1, 2) = 573
COAArray(2, 2) = 742
COAArray(3, 2) = 750
For example, with the repaired array assignment above, COAArray(0, 0) is Apples, COAArray(0, 1) is 498 and COAArray(0, 2) is 570. The following spits out 498 and 570.
Dim i As Long, j As Long
Dim COAArray(3, 2) As Variant, CoaAmt(0 To 1) As Variant
Dim ThisValue As String, AnotherValue As String
AnotherValue = "Bananas"
ThisValue = "Apples"
COAArray(0, 0) = "Apples"
COAArray(1, 0) = "Oranges"
COAArray(2, 0) = "Peaches"
COAArray(3, 0) = "Pomegranets"
COAArray(0, 1) = 498
COAArray(1, 1) = 505
COAArray(2, 1) = 564
COAArray(3, 1) = 556
COAArray(0, 2) = 570
COAArray(1, 2) = 573
COAArray(2, 2) = 742
COAArray(3, 2) = 750
If AnotherValue = "Bananas" Then
For i = LBound(COAArray, 1) To UBound(COAArray, 1)
If COAArray(i, 0) = ThisValue Then
For j = LBound(COAArray, 2) + 1 To UBound(COAArray, 2)
CoaAmt(j - 1) = COAArray(i, j)
Next j
End If
Next i
End If
MsgBox "The value of CoaAmt is " & CoaAmt(LBound(CoaAmt)) & " " & CoaAmt(UBound(CoaAmt))
I had to change your CoaAmt var to a one-dimensioned variant array in order to collect both numbers and output them.
Related
i have problem with my code in vba. I have to find how much similar numbers are in column 1 and 2, but for example Column 1 (6,6,34,21,23,40) and column2 (49,34,6,9,6,20) should write 3 cause there are pairs 6-6, 6-6 and 34-34. I know its messy explenation but i hope its understandable. My code so far is:
Sub totolotek()
Dim i As Integer
Dim x As Integer
Dim j As Integer
Dim liczba As Integer
Dim suma As Integer
Dim ileLosowan As Integer
Range("B2:C7").Interior.Color = RGB(135, 134, 125)
Range("B2:B7").Font.ColorIndex = 3
Range("C2:C7").Font.ColorIndex = 5
ileLosowan = 7
Randomize
For i = 2 To ileLosowan
x = Int(Rnd * (49) + 1)
Range("c" & i) = x
Next i
For i = 2 To 7
liczba = Range("c" & i)
For j = 2 To 7
liczbe = Range("b" & j)
If liczbe = liczba Then
Range("c" & i).Interior.Color = RGB(255, 255, 0)
Range("b" & j).Interior.Color = RGB(255, 255, 0)
suma = suma + 1
End If
Next j
Next i
Range("c" & 9) = suma
End Sub
Try this. I invested some time and I added some lines of code. The macro find all the number pairs.
Example (6,6,3,4,2) (2,3,6,9,0) --> results 3: (6-6, 3-3, 2-2)
Sub totolotek()
Dim i As Integer
Dim x As Integer
Dim j As Integer
Dim liczba As Integer
Dim suma As Integer
Dim ileLosowan As Integer
Dim str_B As String, str_C As String, str_BC As String
Dim max_rand As Long
ileLosowan = 20 ' you can change the number of element in the column
max_rand = 49 ' max randum number
start_row = 2 'start_row
str_BC = "B2:C" & ileLosowan
str_B = "B2:B" & ileLosowan
str_C = "C2:C" & ileLosowan
Range(str_BC).Interior.Color = RGB(135, 134, 125)
Range(str_B).Font.ColorIndex = 5
Range(str_C).Font.ColorIndex = 5
Randomize
For i = start_row To ileLosowan
x = Int(Rnd * (max_rand) + 1)
Range("C" & i) = x
Next i
For i = start_row To ileLosowan
x = Int(Rnd * (max_rand) + 1)
Range("B" & i) = x
Next i
liczba_array = Range("B" & start_row & ":B" & ileLosowan).Value2
liczbe_array = Range("C" & start_row & ":C" & ileLosowan).Value2
ReDim ID_array(1 To 1)
ID_array(1) = max_rand + 1
Count = 1
For i = 1 To UBound(liczba_array, 1)
For j = 1 To UBound(liczbe_array, 1)
For k = 1 To UBound(ID_array, 1)
If ID_array(k) = j Then
GoTo out
End If
Next k
If liczba_array(i, 1) = liczbe_array(j, 1) Then
Range("B" & (start_row + i - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
Range("C" & (start_row + j - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
suma = suma + 1
ID_array(Count) = j
Count = Count + 1
ReDim Preserve ID_array(1 To Count)
Exit For
End If
Next j
out:
Next i
Range("C" & ileLosowan + 2) = suma
End Sub
Something like this will do what you're after. Just incorporate it into you're code cause I don't really know what's going on there.
Dim i As Long, j As Long, arr As Variant, Total As Integer
For i = 2 To 7 'Rows to loop through in the column
Total = 0
arr = Split(Range("A" & i), ",") 'Split column A using the comma
For j = 0 To UBound(arr) 'Loop through the split values
If InStr(Range("B" & i), arr(j)) > 0 Then 'Find if value is within other column
Total = Total + 1 'If it is, add 1 to total
End If
Next j
Range("C" & i) = Total 'Write total to another column on same row
Next i
Or if you want a basic function for it that you can use in your sheet you can use this:
Public Function CountMatches(Cell As String, Rng As Range, Optional Delim As String)
Dim i As Long, j As Long, arr As Variant, Total As Integer
If Delim = "" Then Delim = ","
If Rng.Count > 1 Then
CountMatches = "Please choose 1 cell to compare to."
Exit Function
End If
Total = 0
arr = Split(Cell, Delim) 'Split column A using the comma
For j = 0 To UBound(arr) 'Loop through the split values
If InStr(Rng, arr(j)) > 0 Then 'Find if value is within other column
Total = Total + 1 'If it is, add 1 to total
End If
Next j
CountMatches = Total
End Function
Use it like =CountMatches(A1,B1,",")
I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem
Sub basket()
On Error Resume Next
Dim ps(2, 20)
r = 3
tr = Cells(2, 1)
Item = Cells(2, 2) + "."
ps(1, 1) = 1
ps(2, 1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r, 1) <> ""
If Cells(r, 1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r, 1)
End If
ps(1, ic) = Len(Item) + 1
ps(2, ic) = Len(Cells(r, 2)) + 1
Item = Item + Cells(r, 2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction?
this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.
Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A2:B2").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
I found that from this link.
VBA - Write all possible combinations of 4 columns of data
I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.
I am having an issue with the "Subscript out of Range" error message. I got some help writing a code that loops a long list of stocks. The code basically makes all of the vectors even so i can use it in a panel data setting.
The loop stops after 4 stocks and gives me a "Subscript out of Range" error.
I can run the code over the first 95 "i" i.e. if i transform the first part:
For i = 4 To 95
If Cells(i, 1) <> Cells(i - 1, 1) Then Clean_Stock_2 (i)
Code:
**Sub Outer_Loop()
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row**
If Cells(i, 1) <> Cells(i - 1, 1) Then Clean_Stock_2 (i)
Next i
End Sub
Sub Clean_Stock_2(ByVal r As Long)
Dim Stock(31, 5)
Dim Quarter(31)
Dim Bo As Boolean
Charge = 0
'Frame
For i = 0 To 31
Stock(i, 0) = Cells(r, 1)
Stock(i, 1) = Cells(r, 2)
Stock(i, 2) = Cells(r, 3)
Stock(i, 5) = "Q" & Format(DateAdd("q", i, #1/1/2011#), "q-YYYY")
Quarter(i) = Stock(i, 5)
Next i
'Data
Do While Cells(r, 1) = Stock(0, 0)
Qu = "Q" & Format(Cells(r, 4), "q-YYYY")
rr = Application.Match(Qu, Quarter, 0)
If Not IsError(rr) Then
Stock(rr, 3) = Cells(r, 4)
Stock(rr, 4) = Cells(r, 5)
If Not Bo Then Charge = Stock(rr, 4): Bo = True
End If
r = r + 1
Loop
'fill
For i = 0 To 31
If Stock(i, 4) = 0 Then
Stock(i, 4) = Charge
Else
Charge = Stock(i, 4)
End If
Next i
'Output
lr = Cells(Rows.Count, "I").End(xlUp).Row + 1
lr = IIf(lr < 3, 3, lr)
Cells(lr, "I").Resize(32, 6) = Stock
End Sub
I have the follow script to put a list of people with there know skills in an array and then match the first match with a customer with the same skill. Every time it runs the results are the same. I would like to have it be a random order of the array, but keeping the two columns in the array together. How can I shuffle(rearrange) the array that keeps the rows in the array the same? Or would it be better to erase the array, randomly sort the columns and set the array back up?
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
p = 0
o = 0
For i = 2 To 920
If Cells(i, 12).Value <> Cells(i - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(i, 12).Value
arOne(p, 1) = Cells(i, 13).Value
o = 2
Else
arOne(p, o) = Cells(i, 13).Value
o = o + 1
End If
Next
For i = 2 To 612
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & i), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(i, 2).Value Then
Cells(i, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
GoTo NextIR
End If
Next j
End If
End If
Next o
NextIR:
Next i
End Sub
Multiple loops and multiple access to range objects makes your code very, very slow (I don't know if performance is important).
I would read all necessary data to arrays and use filter and rnd to get a random person with the relevant skill:
Option Explicit
Sub PeopleBusiness()
Dim People, Customers, FilterArray
Dim I As Long, Idx As Long
People = Application.Transpose([L2:L920 & "|" & M2:M8])
Customers = Range("A2:C612").Value2
For I = 1 To UBound(Customers, 1)
FilterArray = Filter(People, Customers(I, 2))
If UBound(FilterArray) > -1 Then
Idx = Round(Rnd() * UBound(FilterArray), 0)
Customers(I, 3) = Left(FilterArray(Idx), InStr(1, FilterArray(Idx), "|") - 1)
End If
Next I
Range("A2:C612").Value = Customers
End Sub
I was able to get done what I needed by erasing the array and redimming it after sorting the data based on a rand() number in the table. It takes about 15 minutes to run 7000 assignment but it is a lot better than 7+ hours it takes to do manually.
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
Application.Calculation = xlAutomatic
StartTime = Timer
NextIR:
ReDim arOne(1000, 15)
p = 0
o = 0
QAlr = Sheets("Sheet1").Range("L" & Rows.Count).End(xlUp).Row
For I = 2 To QAlr
If Cells(I, 12).Value <> Cells(I - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(I, 12).Value
arOne(p, 1) = Cells(I, 13).Value
o = 2
Else
arOne(p, o) = Cells(I, 13).Value
o = o + 1
End If
Next
AQAlr = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
AgtLr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For I = AQAlr + 1 To AgtLr
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & I), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(I, 2).Value Then
Cells(I, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
Erase arOne()
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Random '#]]"), SortOn:=xlSortOnValues, Order:= _
xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
GoTo NextIR
End If
Next j
End If
End If
Next o
Next I
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Assignments completed in " & MinutesElapsed & " minutes", vbInformation
End Sub
Not entirely sure I got your set-up right but you can try this:
Option Explicit
Sub Assign()
Randomize
Range("C2", Range("C" & Rows.Count).End(xlUp)).ClearContents
Dim R1 As Range: Set R1 = Range("L2:M920") 'People skill table
Dim R2 As Range: Set R2 = Range("A2:B612") 'Cusotmers skill talbe
Dim D0 As Object: Set D0 = CreateObject("scripting.dictionary")
Dim i As Integer, j As Integer, Rand as Integer
For i = 1 To R2.Rows.Count
Rand = Int(R1.Rows.Count * Rnd + 1)
For j = 1 To R1.Rows.Count
If R1.Cells(Rand, 2) = R2(i, 2) And Not D0.exists(Rand) Then
R2.Cells(i, 2).Offset(0, 1) = R1(Rand, 1)
D0.Add Rand, Rand
Exit For
End If
Rand = (Rand Mod R1.Rows.Count) + 1
Next j
Next i
End Sub
The idea is to check the people skill list starting from a random point and making sure a key is not used twice.
EDIT:
According to your comment I assume a "people / skill" can then be assigned more than once as there are 7000+ customers ?
Code below randomly assign with a fairly good distribution 1500 peoples to 7000 customers in +/- 1 second.
Have a try and see if you can adapt it to your project.
Option Explicit
Sub Assign()
Application.ScreenUpdating = False
Dim Start: Start = Timer
Randomize
Range("C2:C99999").ClearContents
Dim D1 As Object
Dim R1 As Range: Set R1 = Range("L2", Range("M" & Rows.Count).End(xlUp))
Dim R2 As Range: Set R2 = Range("A2", Range("B" & Rows.Count).End(xlUp))
Dim T1: T1 = R1
Dim T2: T2 = R2
Dim T3()
Dim a As Integer: a = 1
Dim i As Integer, j As Integer, k As Integer, Rnd_Val As Integer, j_loop As Integer
For i = 1 To (Int(R2.Rows.Count / R1.Rows.Count) + 1)
Set D1 = CreateObject("scripting.dictionary")
For j = (R1.Rows.Count * i - R1.Rows.Count + 1) To R1.Rows.Count * i
ReDim Preserve T3(1 To j)
Rnd_Val = Int(Rnd * R1.Rows.Count + 1)
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) And Not D1.exists(Rnd_Val) And T3(j) = "" Then
T3(j) = T1(Rnd_Val, 1)
D1.Add Rnd_Val, Rnd_Val
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
If T3(j) = "" Then
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) Then
T3(j) = T1(Rnd_Val, 1)
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
End If
a = a + 1
If a > R2.Rows.Count Then GoTo EndLoop
Next j
Set D1 = Nothing
Next i
EndLoop:
Range("C2").Resize(UBound(T3), 1) = Application.Transpose(T3)
Debug.Print Timer - Start
Application.ScreenUpdating = True
End Sub
Please see the image attached -
My requirement is -
"If status null and Ref No. not unique then
check value2. If value2 not present, check value1 and take average
Example: For ref number = 1, calculated value is (50+10)/2 = 30 "
"if status is selected or Ref no is unique then
copy from value2, if not present then copy from value1
Example: For Ref No 3, value is 100 and for Ref No 4, value is 20
Total value= 100+30+20 = 150
My attempt
For I = 2 To lrow 'sheets all have headers that are 2 rows
'unique
If Application.WorksheetFunction.CountIf(ws.Range("A" & fRow, "A" & lrow), ws.Range("A" & I)) = 1 Then
If (ws.Range("AW" & I) <> "") Then 'AW has value2
calc = calc + ws.Range("AW" & I).Value
Else: calc = calc + ws.Range("AV" & I).Value 'AV has value1
End If
'not unique
Else
'selected
If ws.Range("AY" & I) = "Selected" Then 'AY has status (Selected/Null)
If (ws.Range("AW" & I) <> "") Then
calc = calc + ws.Range("AW" & I).Value
Else: calc = calc + ws.Range("AV" & I).Value
End If
'not selected
Else
If (ws.Range("AW" & I) <> "") Then
calc1 = calc1 + ws.Range("AW" & I).Value
Else: calc1 = calc1 + ws.Range("AV" & I).Value
End If
calc1 = calc1/Application.WorksheetFunction.CountIf(ws.Range("A" & fRow, "A" & lrow), ws.Range("A" & I))
End If
End If
My problem is -
Getting the Ref No 3 twice in my logic.
Not able to calculate the correct average.
How can I get the correct output? Thanks.
Using a SQL statement against the worksheet
If I understand your requirements, they are as follows:
For each Ref no, you want
the average of
value2 if it exists, otherwise value1
where the status is selected, or
there is no status = selected for this Ref no
I would open an ADODB Recordset against the data, with the following SQL:
SELECT [Ref no], Avg(Iif(value2 IS NOT NULL, value2, value1)) AS Result
FROM Sheet1
LEFT JOIN (
SELECT DISTINCT [Ref No]
FROM Sheet1
WHERE status = "selected"
) t1 ON Sheet1.[Ref no] = t1.[Ref no]
WHERE Sheet1.status="selected" OR t1.[Ref no] IS NULL
GROUP BY [Ref no]
Using nested Scripting.Dictionary
If SQL is not your thing, then you could something like the following:
'Define names for the columns; much easier to read row(RefNo) then arr(0)
Const refNo = 1
Const status = 3
Const value1 = 5
Const value2 = 6
'For each RefNo, we have to store 3 pieces of information:
' whether any of the rows are selected
' the sum of the values
' the count of the values
Dim aggregates As New Scripting.Dictionary
Dim arr() As Variant
arr = Sheet1.UsedRange.Value
Dim maxRow As Long
maxRow = UBound(arr, 1)
Dim i As Long
For i = 2 To maxRow 'exclude the column headers in the first row
Dim row() As Variant
row = GetRow(arr, i)
'Get the current value of the row
Dim currentValue As Integer
currentValue = row(value1)
If row(value2) <> Empty Then currentValue = row(value2)
'Ensures the dictionary always has a record corresponding to the RefNo
If Not aggregates.Exists(row(refNo)) Then Set aggregates(row(refNo)) = InitDictionary
Dim hasPreviousSelected As Boolean
hasPreviousSelected = aggregates(row(refNo))("selected")
If row(status) = "selected" Then
If Not hasPreviousSelected Then
'throw away any previous sum and count; they are from unselected rows
Set aggregates(row(refNo)) = InitDictionary(True)
End If
End If
'only include currently seleced refNos, or refNos which weren't previously selected,
If row(status) = "selected" Or Not hasPreviousSelected Then
aggregates(row(refNo))("sum") = aggregates(row(refNo))("sum") + currentValue
aggregates(row(refNo))("count") = aggregates(row(refNo))("count") + 1
End If
Next
Dim key As Variant
For Each key In aggregates
Debug.Print key, aggregates(key)("sum") / aggregates(key)("count")
Next
with the following two helper functions:
Function GetRow(arr() As Variant, rowIndex As Long) As Variant()
Dim ret() As Variant
Dim lowerbound As Long, upperbound As Long
lowerbound = LBound(arr, 2)
upperbound = UBound(arr, 2)
ReDim ret(1 To UBound(arr, 2))
Dim i As Long
For i = lowerbound To upperbound
ret(i) = arr(rowIndex, i)
Next
GetRow = ret
End Function
Function InitDictionary(Optional selected As Boolean = False) As Scripting.Dictionary
Set InitDictionary = New Scripting.Dictionary
InitDictionary.Add "selected", selected
InitDictionary.Add "sum", 0
InitDictionary.Add "count", 0
End Function
Explanation of SQL
For each Ref no, you want
Group the records by Ref no, using the GROUP BY clause
the average of
We'll return both the Ref no and the average -- SELECT [Ref no], Avg(...)
value2 if it exists, otherwise value1
Iif(value2 IS NOT NULL, value2, value1)
where the status is selected, or
WHERE Sheet1.status="selected" OR
there is no status = selected for this Ref no
We get a list of (unique -- DISTINCT) Ref nos that have status = "selected":
SELECT DISTINCT [Ref No]
FROM Sheet1
WHERE status = "selected"
and give it a name (AS t1) so we can refer to it separately from the main list (Sheet1)
Then we connect, or join (JOIN) that sublist to the main list, where the [Ref no] is the same in both (ON Sheet1.[Ref no] = t1.[Ref no]).
A simple JOIN is an INNER JOIN, where the records on both sides of the connection have to match. What we want in this case, is the records on the main list which do not match the records in the sublist. In order to see such records, we can use a LEFT JOIN, which displays all the records on the left side, and only those records on the right side that match.
We can then filter out the records that do match, using OR t1.[Ref no] IS NULL.
There must be a more concise way, but I think this does what you want. It is based on your example, so data in A1:F6 so will need amending.
Sub x()
Dim v2() As Variant, v1, i As Long, n As Long, d As Double
v1 = Sheet1.Range("A1:F6").Value
ReDim v2(1 To UBound(v1, 1), 1 To 5) 'ref/count/null/value null/value selected
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(v1, 1)
If Not .Exists(v1(i, 1)) Then
n = n + 1
v2(n, 1) = v1(i, 1)
v2(n, 2) = v2(n, 2) + 1
If v1(i, 3) = "" Then
v2(n, 3) = v2(n, 3) + 1
v2(n, 4) = IIf(v1(i, 6) = "", v1(i, 5), v1(i, 6))
ElseIf v1(i, 3) = "selected" Then
v2(n, 5) = IIf(v1(i, 6) = "", v1(i, 5), v1(i, 6))
End If
.Add v1(i, 1), n
ElseIf .Exists(v1(i, 1)) Then
v2(.Item(v1(i, 1)), 2) = v2(.Item(v1(i, 1)), 2) + 1
If v1(i, 3) = "" Then
v2(.Item(v1(i, 1)), 3) = v2(.Item(v1(i, 1)), 3) + 1
If v1(i, 6) = "" Then
v2(.Item(v1(i, 1)), 4) = v2(.Item(v1(i, 1)), 4) + v1(i, 5)
Else
v2(.Item(v1(i, 1)), 4) = v2(.Item(v1(i, 1)), 4) + v1(i, 6)
End If
Else
If v1(i, 6) = "" Then
v2(.Item(v1(i, 1)), 5) = v2(.Item(v1(i, 1)), 5) + v1(i, 5)
Else
v2(.Item(v1(i, 1)), 5) = v2(.Item(v1(i, 1)), 5) + v1(i, 6)
End If
End If
End If
Next i
End With
For i = LBound(v2, 1) To UBound(v2, 1)
If v2(i, 2) > 1 And v2(i, 3) = v2(i, 2) Then
d = d + v2(i, 4) / v2(i, 2)
End If
If v2(i, 2) > 1 And v2(i, 3) < v2(i, 2) Then
d = d + v2(i, 5) / (v2(i, 2) - v2(i, 3))
End If
If v2(i, 2) = 1 And v2(i, 3) = v2(i, 2) Then
d = d + v2(i, 4) / v2(i, 2)
End If
Next i
MsgBox "Total = " & d
End Sub