trying to finish a VBA that processes every 3 rows at a time.
using the order of the rank column, distribute the values accordingly to the next three rows without each cell exceeding the max value of 62 and prioritizing the highest rank.
sample data:
here's what i have so far:
max_value = 62
For irow = 2 To 80 Step 3
set_value = .Cells(irow, 2).Value
'if value less than max, then assign value to highest rank
If set_value < max_value Then
toprank_value = .Range(.Cells(irow, 1), .Cells(irow + 3, 1)).Find(what:="1", LookIn:=xlValues).Address
'assign value to rank of 1
toprank_value.Offset(0, 2).Value = set_value
GoTo NextIteration
'if not, distribute values across next 3 rows based on rank not going over max of 62
Else
'NEED HELP FOR CODE HERE
'NEED HELP FOR CODE HERE
End If
NextIteration:
Next
Thanks for any nudge to the right direction or if clarification is needed.
Assuming your value to distribute is always in the first of the 3 rows.
Its ugly but seems to work.
Sub distrib()
Set R1 = ActiveSheet.UsedRange 'Edit range if other data in sheet
T1 = R1
M = 62
For i = 2 To UBound(T1)
If T1(i, 2) > 0 Then
V = T1(i, 2)
If V <= M Then
For j = i To i + 2
If T1(j, 1) = 1 Then
T1(j, 3) = V
Else
T1(j, 3) = 0
End If
Next j
Else
A = M
V = V - M
If V > M Then
B = M
V = V - M
If V > M Then
C = M
Else
C = V
End If
Else
B = V
C = 0
End If
For j = i To i + 2
Select Case T1(j, 1)
Case Is = 1
T1(j, 3) = A
Case Is = 2
T1(j, 3) = B
Case Is = 3
T1(j, 3) = C
End Select
Next j
End If
End If
Next i
For i = 2 To UBound(T1)
Cells(i, 3) = T1(i, 3)
Next i
End Sub
Related
I have a list of 1000+ names in a single column in excel where the names repeat occasionally. I am trying to count how many times each name occurs. This is what I have currently and it populates the desired sheet but it seems to mess up when counting the number of times the names show up. Anything helps!
m = 2
n = 1
person = Worksheets("Sheet1").Cells(m, 6).Value
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
For i = 0 To Total_Tickets
person = Worksheets("Sheet1").Cells(m, 6).Value
y = 1
d = 0
Do While d <= i
comp = Worksheets("Sorted_Data").Cells(y, 2).Value
x = StrComp(person, comp, vbTextCompare)
If x = 0 Then
Worksheets("Sorted_Data").Cells(n - 1, 3).Value = Worksheets("Sorted_Data").Cells(n - 1, 3).Value + 1
m = m + 1
d = 10000
ElseIf x = 1 Or x = -1 Then
If comp = "" Then
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
d = 10000
End If
y = y + 1
d = d + 1
End If
Loop
Next i
You're managing a lot of counters there, and that makes the logic more difficult to follow.
You could consider something like this instead:
Sub Tester()
Dim wsData As Worksheet, wsList As Worksheet, arr, m, i As Long, nm
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set wsList = ThisWorkbook.Sheets("Sorted_Data")
'grab all the names in an array
arr = wsData.Range("A2:A" & wsData.Cells(Rows.Count, "A").End(xlUp).Row).Value
For i = 1 To UBound(arr, 1) 'loop over the array
nm = arr(i, 1) 'grab the name
m = Application.Match(nm, wsList.Columns("A"), 0) 'existing name on the summary sheet?
If IsError(m) Then
'name was not found: add it to the summary sheet
With wsList.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = nm
m = .Row
End With
End If
With wsList.Cells(m, "B")
.Value = .Value + 1 'update the count
End With
Next i
End Sub
I am trying to construct and If statement that turns a tab Red if two of three cells are colored, or Turns green if only on is colored. I was hoping that there would be an easier way to right it than three if statements like this.
Dim dateRng As String, num As Integer, j As Integer, irng As Range, frng As Range
dateRng = Sheets("Input Raw Data").Range("B" & counter + 2).Value
num = Sheets("Tool Setup").Range("C18").Value
NumPts = num * 3
For s = 1 To Sheets.Count
With Sheets(s)
For j = 1 To num
If .Name = j Then
.Range("A1:C1").Merge
.Range("A1") = dateRng
.Name = Sheets("Point Names").Range("B" & (3 * j - 1))
End If
Next j
End With
Next s
For s = 1 to Sheets.Count
With Sheets(s)
For y = 1 To NumPts
If .Name = Sheets("Reporting").Range("B" & (12 * y - 5)) Then
For k = 6 To -1
Set irng = Sheets("Reporting").Range("A" & (12 * y - k))
Set irng = Sheets("Reporting").Range(irng, irng.End(xlToRight).End(xlToRight))
irng.Copy (.Range("A2"))
Next k
.Columns("A:A").ColumnWidth = 12
.Columns("B:B").EntireColumn.AutoFit
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a >= 2 Then
.Tab.ColorIndex = 3
ElseIf a <= 1 Then
.Tab.ColorIndex = 4
End If
End If
y = y + 2
Next y
End With
Next s
Something like this may help you. It still has multiple if statements. But the statements are simple and don't have to deal with how the combinations of different cells being colored.
Also, I used colorindex > 0 as the condition for having color filling.
a = 0
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a = 2 Then
.Range("B10").Interior.ColorIndex = 3
ElseIf a = 1 Then
.Range("B10").Interior.ColorIndex = 43
End If
I was wondering why the following syntax does not work the way I thought it would in VBA, and what I should do to ensure it does;
For a = 1 To 10
For b = 1 To 10
For c = 1 To 10
If a <> b <> c Then
MsgBox (a & " " & b & " " & c)
End If
Next c
Next b
Next a
This is a simplified example, which can still be manually obtained with:
if a<>b and b<>c and c<>a then
But my actual intended code has 10 such variables multiple times, which makes it unfeasible with 55 unequal conditions, or likely for me to make a typo. I think there is a more efficient way but I have not found it.
Ps. My goal is to only have a message box pop up if all the variables are unique.
I have obtained my goal, though it can probably be done much more efficient than:
For a = 1 To 10
check(a) = True
For b = 1 To 10
If check(b) = False Then
check(b) = True
For c = 1 To 10
If check(c) = False Then
check(c) = True
For d = 1 To 10
If check(d) = False Then
check(d) = True
For e = 1 To 10
If check(e) = False Then
check(e) = True
MsgBox (a & " " & b & " " & c & " " & d & " " & e)
End If
check(e) = False
check(a) = True
check(b) = True
check(c) = True
check(d) = True
Next e
End If
check(d) = False
check(a) = True
check(b) = True
check(c) = True
Next d
End If
check(c) = False
check(a) = True
check(b) = True
Next c
End If
check(b) = False
check(a) = True
Next b
Next a
Here is an implementation of the Johnson-Trotter algorithm for enumerating permutations. It is a small modification of one that I wrote once when playing around with brute-force solutions to the Traveling Salesman Problem. Note that it returns a 2-dimensional array, which might consume a lot of memory. It is possible to refactor it so that it is a sub where the permutations are consumed rather than stored. Just replace the part of the code near the bottom (where the current permutation, perm, is stored in the array perms) by the code that uses the permutation.
Function Permutations(n As Long) As Variant
'implements Johnson-Trotter algorithm for
'listing permutations. Returns results as a variant array
'Thus not feasible for n > 10 or so
Dim perm As Variant, perms As Variant
Dim i As Long, j As Long, k As Long, r As Long, D As Long, m As Long
Dim p_i As Long, p_j As Long
Dim state As Variant
m = Application.WorksheetFunction.Fact(n)
ReDim perm(1 To n)
ReDim perms(1 To m, 1 To n) As Integer
ReDim state(1 To n, 1 To 2) 'state(i,1) = where item i is currently in perm
'state(i,2) = direction of i
k = 1 'will point to current permutation
For i = 1 To n
perm(i) = i
perms(k, i) = i
state(i, 1) = i
state(i, 2) = -1
Next i
state(1, 2) = 0
i = n 'from here on out, i will denote the largest moving
'will be 0 at the end
Do While i > 0
D = state(i, 2)
'swap
p_i = state(i, 1)
p_j = p_i + D
j = perm(p_j)
perm(p_i) = j
state(i, 1) = p_j
perm(p_j) = i
state(j, 1) = p_i
p_i = p_j
If p_i = 1 Or p_i = n Then
state(i, 2) = 0
Else
p_j = p_i + D
If perm(p_j) > i Then state(i, 2) = 0
End If
For j = i + 1 To n
If state(j, 1) < p_i Then
state(j, 2) = 1
Else
state(j, 2) = -1
End If
Next j
'now find i for next pass through loop
If i < n Then
i = n
Else
i = 0
For j = 1 To n
If state(j, 2) <> 0 And j > i Then i = j
Next j
End If
'record perm in perms:
k = k + 1
For r = 1 To n
perms(k, r) = perm(r)
Next r
Loop
Permutations = perms
End Function
Tested like:
Sub test()
Range("A1:G5040").Value = Permutations(7)
Dim A As Variant, i As Long, s As String
A = Permutations(10)
For i = 1 To 10
s = s & " " & A(3628800, i)
Next i
Debug.Print s
End Sub
The first 20 rows of output look like:
Also, 2 1 3 4 5 6 7 8 9 10 is printed in the immediate window. My first version used a vanilla variant away and caused an out-of-memory error with n = 10. I tweaked it so that perms is redimensioned to contain integers (which consume less memory than variants) and is now able to handle 10. It takes about 10 seconds on my machine to run the test code.
You could simply add a check right after the beginning of each inner loop, like follows
For a = 1 To 10
For b = 1 To 10
If b <> a Then '<-- this check will make sure subsequent inner loops shouldn't bother but for their loops variables
For c = 1 To 10
If c <> b Then '<-- same comment as preceeding one
For d = 1 to 10
If d <> c then MsgBox (a & " " & b & " " & c & " " & d) '<-- last check for last two variables
Next d
End If
Next c
End If
Next b
Next a
Try putting all those variables into the array and checking the array for duplicates, if none found, display the message box. Something like this:
Sub dupfind()
Dim ArrHelper(2) As Long
Dim k As Long
Dim j As Long
Dim ans As Long
Dim dupl As Boolean
Dim ArrAnswers() As Long
ans = 0
For a = 1 To 10
ArrHelper(0) = a
For b = 2 To 10
ArrHelper(1) = b
For c = 1 To 10
ArrHelper(2) = c
dupl = False
For k = 0 To UBound(ArrHelper) - 1
For j = k + 1 To UBound(ArrHelper)
If ArrHelper(k) = ArrHelper(j) Then
dupl = True
End If
Next j
Next k
If dupl = False Then
ReDim Preserve ArrAnswers(3, ans)
ArrAnswers(0, ans) = a
ArrAnswers(1, ans) = b
ArrAnswers(2, ans) = c
ans = ans + 1
End If
Next c
Next b
Next a
End Sub
Read your edit regarding storing permutations and changed the code a bit
This is an addition question of my previous post. I was not able to find a way to figure it out for hours nor also to find an idea from online search.
Suppose I have the following data (the actual data can be thousands or millions) in Excel sheet (Table 1):
Name Entry No. ID Expense 1 Expense 2
A 1 A1 14 5
B 2 B4 12 7
B 2 B5 20 8
C 3 C0 19 7
D 4 - 0 0
A 1 A1 11 6
A 1 A2 20 5
E 5 - 0 0
F 6 - 0 0
C 3 C0 15 5
B 2 B5 20 4
B 2 B5 16 3
B 2 B5 12 7
B 2 B6 18 8
A 1 A1 10 1
A 1 A1 14 7
A 1 A2 10 2
B 2 B3 13 7
B 2 B3 14 1
B 2 B3 11 4
The character (-) in column No. ID above can be also a number 0 or a blank cell.
I want to format the above data as follow (Table 2)
Name Entry No. ID Number of ID Sum of Expense 1 Sum of Expense 2
A 1 A1 2 49 19
A 1 A2 2 30 7
B 2 B3 4 38 12
B 2 B4 4 12 7
B 2 B5 4 68 22
B 2 B6 4 18 8
C 3 C0 1 34 12
D 4 - 0 0 0
E 5 - 0 0 0
F 6 - 0 0 0
Column Number of ID means A has 2 IDs (A1 and A2), B has 4 IDs (B1, B2, B3, and B4), C has 1 ID (C0), and D, E, and F have no ID. Column Sum of Expense 1 and 2 are the sum of all expense for each no. ID.
The best I can get by using Pivot Table is like this
How does one perform a task like Table 2 in MS Excel? If possible a VBA script of it.
This code after modifications works when running it from the same Workbook (doesn't matter which Worksheet).
Added an array to dynamic add number Sum of Expense types.
This code covers the logic needed to convert you table's data just like you wanted.
Sub OrganizeTable()
Dim TableArray() As Variant
Dim i, j, k, i_tmp, LastRow As Long
Dim Sum_Count As Integer
Dim SheetData, SheetResult As Excel.Worksheet
Dim StringTemp As String
Dim LongMin, LongMax As Long
Dim SumExpense() As Long
Dim Number_of_ID As Long
Dim Number_of_Expense_Type As Integer
' Number_of_Expense_Type = number of expense type you have in your
Number_of_Expense_Type = InputBox("Enter number of expense type ", "Expense Type counter")
Set SheetData = ActiveWorkbook.Worksheets("Sheet1")
LastRow = SheetData.Cells(SheetData.Rows.Count, "A").End(xlUp).row
Set SheetResult = ActiveWorkbook.Worksheets("Sheet2")
Erase TableArray
ReDim TableArray(1 To LastRow - 1, 1 To 3 + Number_of_Expense_Type) ' create array with exact number of Project names
ReDim SumExpense(1 To Number_of_Expense_Type)
i = 2
' insert all table's data into multi-dimensional array (easier and faster to manipulate later)
While SheetData.Cells(i, 1) <> ""
For j = 1 To 3 + Number_of_Expense_Type
TableArray(i - 1, j) = SheetData.Cells(i, j)
Next
i = i + 1
Wend
LongMin = LBound(TableArray())
LongMax = UBound(TableArray())
' this loop is for sorting the array according to Name, and then No. ID
For i = LongMin To LongMax - 1
For j = i + 1 To LongMax
' 1st rule: check for Name Value in Column A
If TableArray(i, 1) > TableArray(j, 1) Then
For k = 1 To 3 + Number_of_Expense_Type
StringTemp = TableArray(i, k)
TableArray(i, k) = TableArray(j, k)
TableArray(j, k) = StringTemp
Next
End If
' 2nd rule: check for No. ID in Column c
If TableArray(i, 1) = TableArray(j, 1) And TableArray(i, 3) > TableArray(j, 3) Then
For k = 1 To 3 + Number_of_Expense_Type
StringTemp = TableArray(i, k)
TableArray(i, k) = TableArray(j, k)
TableArray(j, k) = StringTemp
Next
End If
Next
Next
i = 1
j = 2 ' this is the Row number where the sorted table will start
k = 1 ' this is the Column number where the sorted table will start
While i <= LongMax
SheetResult.Cells(j, k) = TableArray(i, 1)
SheetResult.Cells(j, k + 1) = TableArray(i, 2)
SheetResult.Cells(j, k + 2) = TableArray(i, 3)
For Sum_Count = 1 To Number_of_Expense_Type
SumExpense(Sum_Count) = TableArray(i, 4 + Sum_Count - 1)
Next
' this IF and WHILE loop are for accumulating the Sum Expense 1 and Sum Expense 2 for the same ID type
If i + 1 <= LongMax Then
While TableArray(i, 3) = TableArray(i + 1, 3) And TableArray(i, 1) = TableArray(i + 1, 1)
For Sum_Count = 1 To Number_of_Expense_Type
SumExpense(Sum_Count) = SumExpense(Sum_Count) + Val(TableArray(i + 1, 4 + Sum_Count - 1))
Next
i = i + 1
Wend
End If
' this IF and WHILE loop are for counting how many Num of ID you have per Name
Number_of_ID = 0
If TableArray(i, 3) <> "-" Then
Number_of_ID = 1
For i_tmp = 1 To LongMax - 1
While Cells(j, k) = TableArray(i_tmp + 1, 1) And TableArray(i_tmp, 1) = TableArray(i_tmp + 1, 1) And TableArray(i_tmp, 3) <> TableArray(i_tmp + 1, 3)
Number_of_ID = Number_of_ID + 1
i_tmp = i_tmp + 1
Wend
Next
Else
Number_of_ID = 0
End If
SheetResult.Cells(j, k + 3) = Number_of_ID
For Sum_Count = 1 To Number_of_Expense_Type
SheetResult.Cells(j, k + 4 + Sum_Count - 1) = SumExpense(Sum_Count)
SumExpense(Sum_Count) = 0
Next
Number_of_ID = 0
j = j + 1
i = i + 1
Wend
' writing down the headers for you table
SheetResult.Cells(1, k) = "Name"
SheetResult.Cells(1, k + 1) = "Entry"
SheetResult.Cells(1, k + 2) = "No. ID"
SheetResult.Cells(1, k + 3) = "Number of ID"
For Sum_Count = 1 To Number_of_Expense_Type
SheetResult.Cells(1, k + 4 + Sum_Count - 1) = "Sum of Expense " & Sum_Count
Next
Set SheetData = Nothing
Set SheetResult = Nothing
End Sub
Below code might help:
Assumptions:
1. Your data is in ActiveSheet
2. Result will be displayed in the Sheet2
Sub Demo()
Dim dict1 As Object, dict2 As Object
Dim c1 As Variant, c2 As Variant
Dim i As Long, lastRow As Long, targetRow As Long, count As Long
Dim targetWS As Worksheet
Set targetWS = ThisWorkbook.Sheets("Sheet2")
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
'get last row with data
lastRow = Cells(Rows.count, "A").End(xlUp).Row
'assign unique values in Column A (Name) to dict1
c1 = Range("A2:A" & lastRow)
For i = 1 To UBound(c1, 1)
dict1(c1(i, 1)) = 1
Next i
'assign unique values in Column C (No. Id) to dict2
c2 = Range("C2:C" & lastRow)
For i = 1 To UBound(c2, 1)
dict2(c2(i, 1)) = 1
Next i
'write headers in Sheet2
targetWS.Cells(1, 1) = "Name"
targetWS.Cells(1, 2) = "Entry"
targetWS.Cells(1, 3) = "No. Id"
targetWS.Cells(1, 4) = "Number of ID"
targetWS.Cells(1, 5) = "Sum of Expense 1"
targetWS.Cells(1, 6) = "Sum of Expense 2"
'fill data in table
targetRow = 2 '-->targetRow will keep the counter for new row in Sheeet2
'loop through unique values of Name through dict1
For Each k1 In dict1.Keys
count = 0
'loop through unique No. ID through dict2 to match values in dict1 and dict2
For Each k2 In dict2.Keys
If k2 Like k1 & "*" Then '-->match values of dict1 and dict2
count = count + 1
'fill data in table if match found
targetWS.Cells(targetRow, 1) = k1
targetWS.Cells(targetRow, 3) = k2
targetWS.Cells(targetRow, 4) = dict2(k2)
targetWS.Cells(targetRow, 5) = Application.WorksheetFunction.SumIf(Range("C2:C" & lastRow), k2, Range("D2:D" & lastRow))
targetWS.Cells(targetRow, 6) = Application.WorksheetFunction.SumIf(Range("C2:C" & lastRow), k2, Range("E2:E" & lastRow))
targetRow = targetRow + 1
End If
Next k2
'fill data if no match found
If count = 0 Then
targetWS.Cells(targetRow, 1) = k1
targetWS.Cells(targetRow, 3) = "-"
targetWS.Cells(targetRow, 5) = 0
targetWS.Cells(targetRow, 6) = 0
targetRow = targetRow + 1
End If
Next k1
'get values for Entry and Number of ID
For i = 2 To targetWS.Cells(Rows.count, "A").End(xlUp).Row
targetWS.Cells(i, 2) = Range("A:A").Find(What:=targetWS.Cells(i, 1), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True).Offset(0, 1).Value
targetWS.Cells(i, 4) = Application.WorksheetFunction.CountIf(targetWS.Range("A1:A" & lastRow), targetWS.Cells(i, 1))
Next i
End Sub
Note: Above code will not display data in ascending order like A1-A2-B3-B4-B5-B6-C0 instead data will be displayed in the order of appearance like A1-A2-B4-B5-B6-B3-C0
See image for reference:
You can have VBA to copy the pivot table data and paste it as normal table.
In excel, I have column 1 with tickers, and column 2 with numbers, like this:
A B
1 AAA 10
2 AAA 12
3 AAA 14
4 BBB 9
5 BBB 10
6 BBB 11
I need a piece of code to calculate average BY TICKER, which means that in this case I would have AAA average : 12 and BBB average = 10, etc etc etc. Up to now all i got is this code which tries to calculate the sums, I will do the divisions later, but something's wrong:
For row = 2 to 6
Ticker = Cells(row - 1, 1)
If Cells(row, 1) = Cells(row - 1, 1) Then
sum = sum + Cells(row, 2)
Else
Cells(row, 6) = sum
sum = 0
row = row + 1
Next
I get an error saying "For is missing"
Maybe something like this in C1.
=IF(A1<>A2,AVERAGEIF(A:A,A1,B:B),"")
In your code:
sum ignored the first AAA
missed the End If
incremented row twice, once by row = row+1 and then by next
and some other not used variables
Try this:
Prev = "***"
For row = 1 to 6
If Cells(row, 1) = prev Then
sum = sum + Cells(row, 2)
Else
Cells(row, 6) = sum
sum = 0
End If
prev = Cells(row,1)
Next
To extend the answer from Jeeped and do it with a list which is not ordered, you also could do it like this:
C1: =A1
C2: =IF(LEN(C1),IFERROR(INDEX(A:A,MATCH(1,(COUNTIF(C$1:C1,A$1:A$1000)=0)*(A$1:A$1000<>""),0)),""),"")}
C3....Cn: copy down from C2
D1: =IF(LEN(C1),AVERAGEIF(A:A,C1,B:B),"")
D2...Dn: copy down from D1
C2 is an array formula and needs to be confirmed with Ctrl+Shift+Enter
to do it via VBA (should be faster than my formula for really big tables) you can use something like that: (put this in a "Module" in the VBA-Window, the same like your recorded macros ar written)
Option Explicit
Public Function getAllAvg(rng As Range) As Variant
Set rng = Intersect(rng.Parent.UsedRange, rng)
Dim varInput As Variant
varInput = rng.Value
Dim varOutput() As Variant
ReDim varOutput(1 To UBound(varInput), 1 To 2)
varOutput(1, 1) = ""
Dim i As Long, j As Long
For i = 1 To UBound(varInput)
If Len(varInput(i, 1)) Then
j = 1
While Len(varOutput(j, 1)) And (varOutput(j, 1) <> varInput(i, 1)) And (j < UBound(varOutput))
j = j + 1
Wend
If Len(varOutput(j, 1)) = 0 Then
varOutput(j, 1) = varInput(i, 1)
varOutput(j, 2) = Application.AverageIf(rng.Columns(1), varOutput(j, 1), rng.Columns(2))
varOutput(j + 1, 1) = ""
End If
End If
Next
While Len(varOutput(j, 1)) And (j < UBound(varOutput))
j = j + 1
Wend
If Len(varOutput(j, 1)) = 0 Then
For i = j To UBound(varOutput)
varOutput(i, 1) = ""
varOutput(i, 2) = ""
Next
End If
getAllAvg = varOutput
End Function
then select a range like C2:D12 and enter:
=getAllAvg(A:B)
and confirm with Ctrl+Shift+Enter. it will directly output the whole list (and recalculate if needed)
EDIT:
If your list is always in a sorted order, you also could use this code:
Option Explicit
Public Function getAllAvgSorted(rng As Range) As Variant
Set rng = Intersect(rng.Parent.UsedRange, rng)
Dim varInput As Variant
varInput = rng.Value
Dim varOutput() As Variant
ReDim varOutput(1 To UBound(varInput), 1 To 2)
varOutput(1, 1) = ""
Dim i As Long, j As Long
j = 1
For i = 1 To UBound(varInput)
If Len(varInput(i, 1)) Then
If varOutput(j, 1) <> varInput(i, 1) Then
If Len(varOutput(j, 1)) Then j = j + 1
varOutput(j, 1) = varInput(i, 1)
varOutput(j, 2) = Application.AverageIf(rng.Columns(1), varOutput(j, 1), rng.Columns(2))
End If
End If
Next
While j < UBound(varOutput)
j = j + 1
varOutput(j, 1) = ""
varOutput(j, 2) = ""
Wend
getAllAvgSorted = varOutput
End Function