VBA Complicated Loop

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
785
Office Version
  1. 365
Platform
  1. Windows
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>


792a8b817c.png


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:

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
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:
Upvote 0
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

mjFgLo5.png
 
Upvote 0
Re: VBA Complicated Loop Help

It did go to ID 2. Are you looking at the right column for the ID numbers?
 
Upvote 0
For John,
ID2 has 20 Points assigned

But in the outcome he has
ID1 - 70
ID2 - 10
 
Upvote 0
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).
 
Upvote 0
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:
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,254
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top