VBA Complicated Loop

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
609
Hi,
I have 2 tables

Table1 - Source with Total Points

IDNamePoints
1John23
2Luke5
4Tim11
5Fran1
6Bob6
13Bob6
14Luke8
15Tim3

<tbody>
</tbody>

and Table 2 is input data:
NamePointsDay
John51
John11
John172
Luke62
Luke73
Tim143
Fran13
Bob43
Bob84

<tbody>
</tbody>

I need to get a breakdown of each day points, but the requirement is that the first ID of the user must be fulfilled and if exceeded then rest are assigned to their next ID until filled:
So expected result is like so:
DayIDNamePoints
11John6
21John17
22Luke5
214Luke1
314Luke7
34Tim11
315Tim3
35Fran1
36Bob4
46Bob2
413Bob6

<tbody>
</tbody>




So Luke for example:
6 Points on Day 2
7 Points on Day 3

but Luke: ID 2 only holds 5 Points
5 Points goes to ID 2
Next points go to their next ID

Sometimes more than 2 IDs

Any help appreciated
 
Last edited:

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
8,787
Re: VBA Complicated Loop Help

Funny how I just recently said that a dictionary of dictionaries should be hardly ever used, but I use one here! :confused:

A question about your results. On row 6, 3/14/Luke/7. Why aren't any points allocated to 2/Luke? Shouldn't 2/Luke get 6, and 14/Luke get 1? Looking at Bob, his values reset between day 3 and 4.

In any event, here's what I came up with. If your results are correct, I'll have to adapt it.

Rich (BB code):
Sub AllocatePoints()
Dim Source As Object, SourceTable As Variant, OutTable() As Variant, InputTable As Variant
Dim i As Long, j As Long, r As Long, ix As Long, x As Double
Dim RowsPerDay As Long, MinDay As Long, MaxDay As Long, MaxRows As Long
Dim Name1 As Variant, ID As Variant

    Set Source = CreateObject("Scripting.Dictionary")
    SourceTable = Range("B2:D" & Cells(Rows.Count, "C").End(xlUp).Row).Value
    
    For i = 1 To UBound(SourceTable)
        If Not Source.exists(SourceTable(i, 2)) Then
            Source.Add SourceTable(i, 2), CreateObject("Scripting.Dictionary")
        End If
        Source(SourceTable(i, 2)).Add SourceTable(i, 1), SourceTable(i, 3)
    Next i
    RowsPerDay = 0
    For Each Name1 In Source
        Source(Name1).Add "Excess", 9999999
        RowsPerDay = RowsPerDay + Source(Name1).Count
    Next Name1
    
    MinDay = WorksheetFunction.Min(Range("I:I"))
    MaxDay = WorksheetFunction.Max(Range("I:I"))
    MaxRows = (MaxDay - MinDay + 1) * RowsPerDay
    ReDim OutTable(1 To MaxRows, 1 To 4)
    ix = 0
    For i = MinDay To MaxDay
        For Each Name1 In Source
            For Each ID In Source(Name1)
                ix = ix + 1
                OutTable(ix, 1) = i
                OutTable(ix, 2) = ID
                OutTable(ix, 3) = Name1
                OutTable(ix, 4) = 0
            Next ID
        Next Name1
    Next i
    
    InputTable = Range("G1:I" & Cells(Rows.Count, "G").End(xlUp).Row).Value
    For i = 1 To UBound(InputTable)
        For j = 1 To UBound(OutTable)
            If OutTable(j, 1) = InputTable(i, 3) And _
               OutTable(j, 3) = InputTable(i, 1) Then
               x = WorksheetFunction.Min(InputTable(i, 2), Source(OutTable(j, 3))(OutTable(j, 2)) - OutTable(j, 4))
               OutTable(j, 4) = OutTable(j, 4) + x
               InputTable(i, 2) = InputTable(i, 2) - x
               If InputTable(i, 2) = 0 Then Exit For
            End If
        Next j
    Next i
    
    r = 1
    Range("N1:Q1").Value = Array("Day", "ID", "Name", "Points")
    For i = 1 To MaxRows
        If OutTable(i, 4) > 0 Then
            r = r + 1
            Cells(r, "N").Resize(, 4).Value = WorksheetFunction.Index(OutTable, i, 0)
        End If
    Next i
        
End Sub
The IDs in the output table come out in the order that they're found in your source table. So if you want them sorted, the source table should be sorted by ID.
I followed the locations of your data in your sample sheet. If you want to change anything, I marked the ranges in red. Let me know how this works for you.
 
Last edited:

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
609
Re: VBA Complicated Loop Help

Thanks @Eric W
You was right with your question it was just my input

I tried this code on a small dataset and you see
60 has gone to ID:1 for John
But then another 10 has gone to ID: 1 Also when it should go to ID:2

 

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
8,787
Re: VBA Complicated Loop Help

It did go to ID 2. Are you looking at the right column for the ID numbers?
 

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
609
For John,
ID2 has 20 Points assigned

But in the outcome he has
ID1 - 70
ID2 - 10
 

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
8,787
In the INPUT, John has 70 points assigned for day 1. In the OUTPUT, John ID1 has 60 points assigned (Q2), and ID2 has 10 points assigned (Q3).
 

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
8,787
Whew! Glad to hear it. It's kind of tricky, so I would have not been surprised if it needed changes. Glad I could help. :cool:
 

Forum statistics

Threads
1,077,849
Messages
5,336,734
Members
399,100
Latest member
darcob

Some videos you may like

This Week's Hot Topics

Top