Fill out empty slots with a loop

E

excelhjalp

New Member
Joined
Aug 7, 2018
Messages
33
Office Version
  1. 365
Platform
  1. Windows
Good day!

I have a problem I can't solve in VBA. I have two tables, the first one with three columns: The name of players (distinct), date when they are available from and date when they are available to.

In the second table I have four columns. One date column, one column that contains slots that players need to be assigned to, thrid column stating if the slot is available on a given day and the forth column is the one that needs to be filled out.

The problem is that I need to fill out the slots each day with the players available, no player can be in two or more slots. So the VBA code should check which players are available based on given dates and fill out the slots available. In case there aren't enough slots available for all the players, I would need to know which players were left out. In the cases where the slots are more than the players, it should simply be empty, like in the file attached.

I hope this is clear. Please let me know if anything is unclear
smile.gif


Thank you so much for your help!

Regards,
Sveppi
 

Attachments

  • Capture.PNG
    Capture.PNG
    18.4 KB · Views: 14

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
Hi and welcome to MrExcel board!

Your image is not very clear, since the rows and columns are not visible.
But assuming your data is like this:
Dante Amor
ABCDEFGHI
1PlayerAvailable fromAvailable toDateSlotAvailablePlayer
2John31/08/202230/11/202201/08/20221YesJane
3Smith01/11/202231/01/202301/08/20222YesEmil
4Anna31/08/202230/11/202201/08/20223No
5Alan31/08/202230/11/202201/08/20224No
6Jane01/08/202231/10/202202/08/20221YesDavid
7Rosy31/08/202230/11/202202/08/20222No
8Emil01/07/202230/09/202202/08/20223No
9David01/07/202230/09/202202/08/20224No
10Paula01/06/202231/08/202203/08/20221YesPaula
1103/08/20222No
1203/08/20223No
1303/08/20224No
14
Hoja2

Try this macro:
VBA Code: 
Sub Fill_out_empty_slots()
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long
  Dim rng As Range
 
  a = Range("A2:D" & Range("A" & Rows.Count).End(3).Row).Value
  b = Range("F2:H" & Range("F" & Rows.Count).End(3).Row).Value
  ReDim c(1 To UBound(b, 1), 1 To 1)
 
  'fill out the slots available
  For i = 1 To UBound(b, 1)
    If b(i, 3) = "Yes" Then
      For j = 1 To UBound(a, 1)
        If a(j, 2) <= b(i, 1) And a(j, 3) >= b(i, 1) And a(j, 4) <> "@" Then
          c(i, 1) = a(j, 1)
          a(j, 4) = "@"
          Exit For
        End If
      Next j
    End If
  Next
 
  'which players were left out
  For j = 1 To UBound(a, 1)
    If a(j, 4) <> "@" Then
      For i = 1 To UBound(b, 1)
        If a(j, 2) <= b(i, 1) And a(j, 3) >= b(i, 1) Then
          If rng Is Nothing Then Set rng = Range("A" & j + 1) Else Set rng = Union(rng, Range("A" & j + 1))
        End If
      Next
    End If
  Next
 
  Range("I2").Resize(UBound(c, 1)).Value = c
  Range("A2:A" & Rows.Count).Interior.Color = xlNone
  If Not rng Is Nothing Then rng.Interior.Color = vbYellow
End Sub

NOTE XL2BB:
For the future, it would help greatly if you could give us the sample data in a form that we can copy to test with, rather that a picture.
MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in
Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.
 
Upvote 0
Solution
DanteAmor said:
Hi and welcome to MrExcel board!

Your image is not very clear, since the rows and columns are not visible.
But assuming your data is like this:
Dante Amor
ABCDEFGHI
1PlayerAvailable fromAvailable toDateSlotAvailablePlayer
2John31/08/202230/11/202201/08/20221YesJane
3Smith01/11/202231/01/202301/08/20222YesEmil
4Anna31/08/202230/11/202201/08/20223No
5Alan31/08/202230/11/202201/08/20224No
6Jane01/08/202231/10/202202/08/20221YesDavid
7Rosy31/08/202230/11/202202/08/20222No
8Emil01/07/202230/09/202202/08/20223No
9David01/07/202230/09/202202/08/20224No
10Paula01/06/202231/08/202203/08/20221YesPaula
1103/08/20222No
1203/08/20223No
1303/08/20224No
14
Hoja2

Try this macro:
VBA Code: 
Sub Fill_out_empty_slots()
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long
  Dim rng As Range
 
  a = Range("A2:D" & Range("A" & Rows.Count).End(3).Row).Value
  b = Range("F2:H" & Range("F" & Rows.Count).End(3).Row).Value
  ReDim c(1 To UBound(b, 1), 1 To 1)
 
  'fill out the slots available
  For i = 1 To UBound(b, 1)
    If b(i, 3) = "Yes" Then
      For j = 1 To UBound(a, 1)
        If a(j, 2) <= b(i, 1) And a(j, 3) >= b(i, 1) And a(j, 4) <> "@" Then
          c(i, 1) = a(j, 1)
          a(j, 4) = "@"
          Exit For
        End If
      Next j
    End If
  Next
 
  'which players were left out
  For j = 1 To UBound(a, 1)
    If a(j, 4) <> "@" Then
      For i = 1 To UBound(b, 1)
        If a(j, 2) <= b(i, 1) And a(j, 3) >= b(i, 1) Then
          If rng Is Nothing Then Set rng = Range("A" & j + 1) Else Set rng = Union(rng, Range("A" & j + 1))
        End If
      Next
    End If
  Next
 
  Range("I2").Resize(UBound(c, 1)).Value = c
  Range("A2:A" & Rows.Count).Interior.Color = xlNone
  If Not rng Is Nothing Then rng.Interior.Color = vbYellow
End Sub

NOTE XL2BB:
For the future, it would help greatly if you could give us the sample data in a form that we can copy to test with, rather that a picture.
MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in
Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.
Click to expand...


Hi DanteAmor


I apologize for not using the XL2bb, this was my first post and from here on I promise to use it :D
And thank you kindly for such a quick and good response! It really helped a lot. I do wonder though if the code would need major adjustments if the available from and to dates would be transformed into a single column with available dates, since players might be available f.ex. 1.8.22, 15.8.22 and 31.8.22. Do you have an idea how the code would need to be adjusted for this? So if a player has been asigned a slot in the second table then he should not be assigned another one.
This time I'm attaching the Xl2bb table in the post! ;)

Best regards,
Sveppi

Book1
ABCDEFGHIJK
1PlayerAvailableDateSlotAvailablePlayer
2John1.8.20221.8.20221YesJohn
3John2.8.20221.8.20222YesAnna
4John3.8.20221.8.20223No
5John6.8.20221.8.20224No
6John7.8.20222.8.20221YesSmith
7John8.8.20222.8.20222No
8Smith2.8.20222.8.20223YesAlan
9Smith3.8.20222.8.20224No
10Smith5.8.20223.8.20221No
11Smith8.8.20223.8.20222No
12Smith9.8.20223.8.20223Yes
13Smith10.8.20223.8.20224Yes
14Anna1.8.20224.8.20221No
15Anna2.8.20224.8.20222Yes
16Anna3.8.20224.8.20223No
17Anna5.8.20224.8.20224No
18Anna6.8.2022
19Anna7.8.2022
20Alan1.8.2022
21Alan2.8.2022
22Alan3.8.2022
23Alan4.8.2022
24Alan5.8.2022
25Alan6.8.2022
26Eric1.8.2022
27Eric2.8.2022
28
29
30
Sheet1
 
Upvote 0
Try this:

VBA Code: 
Sub Fill_out_empty_slots()
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long
  Dim rng As Range
  Dim dic As Object
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:C" & Range("A" & Rows.Count).End(3).Row).Value
  b = Range("F2:H" & Range("F" & Rows.Count).End(3).Row).Value
  ReDim c(1 To UBound(b, 1), 1 To 1)
  
  'fill out the slots available
  For i = 1 To UBound(b, 1)
    If b(i, 3) = "Yes" Then
      For j = 1 To UBound(a, 1)
        If a(j, 2) = b(i, 1) And a(j, 3) <> "@" Then
          If Not dic.exists(a(j, 1)) Then
            dic(a(j, 1)) = Empty
            c(i, 1) = a(j, 1)
            a(j, 3) = "@"
            Exit For
          End If
        End If
      Next j
    End If
  Next
  
  'which players were left out
  For j = 1 To UBound(a, 1)
    If Not dic.exists(a(j, 1)) Then
      If a(j, 3) <> "@" Then
        For i = 1 To UBound(b, 1)
          If a(j, 2) = b(i, 1) And b(i, 3) = "Yes" And c(i, 1) <> "" Then
            If rng Is Nothing Then
              Set rng = Range("A" & j + 1).Resize(1, 2)
            Else
              Set rng = Union(rng, Range("A" & j + 1).Resize(1, 2))
            End If
          End If
        Next
      End If
    End If
  Next
  
  Range("I2").Resize(UBound(c, 1)).Value = c
  Range("A2:B" & Rows.Count).Interior.Color = xlNone
  If Not rng Is Nothing Then rng.Interior.Color = vbYellow
End Sub
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
Sub Fill_out_empty_slots()
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long
  Dim rng As Range
  Dim dic As Object
 
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:C" & Range("A" & Rows.Count).End(3).Row).Value
  b = Range("F2:H" & Range("F" & Rows.Count).End(3).Row).Value
  ReDim c(1 To UBound(b, 1), 1 To 1)
 
  'fill out the slots available
  For i = 1 To UBound(b, 1)
    If b(i, 3) = "Yes" Then
      For j = 1 To UBound(a, 1)
        If a(j, 2) = b(i, 1) And a(j, 3) <> "@" Then
          If Not dic.exists(a(j, 1)) Then
            dic(a(j, 1)) = Empty
            c(i, 1) = a(j, 1)
            a(j, 3) = "@"
            Exit For
          End If
        End If
      Next j
    End If
  Next
 
  'which players were left out
  For j = 1 To UBound(a, 1)
    If Not dic.exists(a(j, 1)) Then
      If a(j, 3) <> "@" Then
        For i = 1 To UBound(b, 1)
          If a(j, 2) = b(i, 1) And b(i, 3) = "Yes" And c(i, 1) <> "" Then
            If rng Is Nothing Then
              Set rng = Range("A" & j + 1).Resize(1, 2)
            Else
              Set rng = Union(rng, Range("A" & j + 1).Resize(1, 2))
            End If
          End If
        Next
      End If
    End If
  Next
 
  Range("I2").Resize(UBound(c, 1)).Value = c
  Range("A2:B" & Rows.Count).Interior.Color = xlNone
  If Not rng Is Nothing Then rng.Interior.Color = vbYellow
End Sub
Click to expand...

Truly fantastic! Thank you so much!!
 
Upvote 0
DanteAmor said:
Try this:

VBA Code: 
Sub Fill_out_empty_slots()
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long
  Dim rng As Range
  Dim dic As Object
 
  Set dic = CreateObject("Scripting.Dictionary")
  a = Range("A2:C" & Range("A" & Rows.Count).End(3).Row).Value
  b = Range("F2:H" & Range("F" & Rows.Count).End(3).Row).Value
  ReDim c(1 To UBound(b, 1), 1 To 1)
 
  'fill out the slots available
  For i = 1 To UBound(b, 1)
    If b(i, 3) = "Yes" Then
      For j = 1 To UBound(a, 1)
        If a(j, 2) = b(i, 1) And a(j, 3) <> "@" Then
          If Not dic.exists(a(j, 1)) Then
            dic(a(j, 1)) = Empty
            c(i, 1) = a(j, 1)
            a(j, 3) = "@"
            Exit For
          End If
        End If
      Next j
    End If
  Next
 
  'which players were left out
  For j = 1 To UBound(a, 1)
    If Not dic.exists(a(j, 1)) Then
      If a(j, 3) <> "@" Then
        For i = 1 To UBound(b, 1)
          If a(j, 2) = b(i, 1) And b(i, 3) = "Yes" And c(i, 1) <> "" Then
            If rng Is Nothing Then
              Set rng = Range("A" & j + 1).Resize(1, 2)
            Else
              Set rng = Union(rng, Range("A" & j + 1).Resize(1, 2))
            End If
          End If
        Next
      End If
    End If
  Next
 
  Range("I2").Resize(UBound(c, 1)).Value = c
  Range("A2:B" & Rows.Count).Interior.Color = xlNone
  If Not rng Is Nothing Then rng.Interior.Color = vbYellow
End Sub
Click to expand...

Hi again DanteAmor!

I'm wondering if I can bother you with a slight follow up question regarding the problem. Now the code takes the first slot in table b and finds if any players are available to assign to that slot, then the second slot in table b and etc.. Is it possible to change that into to assign the players into table b based on their order. The idea is to put a custom sort column in table a where a player has numerical values (1, 2, 3... etc.) and sort table a based on that column. In the attached table we can see that the most preferred date for John is 3.8.22, that slot is available in table b so John is assigned to that slot. Next up is Smith, his preferred date is 7.8.22, that slot is available in table b so he is assigned into that slot. Next up is Anna and she is assigned to slot on the date 6.8.22. Then it's Alan, his most preferred date is 5.8.22, but no slots are available then. Next up is Eric and he takes his most preferred slot on the date 2.8.22. Now Alan is still without a slot since there were no slots available on his preferred date. His next most preferred date is 1.8.22 (the next row where his name is in table a) and that slot is available in table b, so he is assigned to that slot.

Is it possible to change the code to take this into consideration, or is it perhaps a major adjustment that takes a lot of time?

And thank you for all the answers :)

Here's the table:
Book1
ABCDEFGHI
1PlayerAvailableOrderDateSlotAvailablePlayer
2John3.8.202211.8.20221YesJohn
3Smith7.8.202211.8.20222YesAlan
4Anna6.8.202211.8.20223No
5Alan5.8.202211.8.20224No
6Eric2.8.202212.8.20221YesEric
7John6.8.202222.8.20222No
8Smith6.8.202222.8.20223Yes
9Anna7.8.202224.8.20222Yes
10Alan1.8.202224.8.20223No
11Eric1.8.202224.8.20224No
12John7.8.202236.8.20221YesAnna
13Smith5.8.202236.8.20222Yes
14Anna2.8.202237.8.20221YesSmith
15Alan4.8.202237.8.20222Yes
16John2.8.20224
17Smith2.8.20224
18Anna5.8.20224
19Alan3.8.20224
20John1.8.20225
21Smith3.8.20225
22Anna3.8.20225
23Alan2.8.20225
24John8.8.20226
25Alan6.8.20226
Sheet2



Best
Sveppi
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Moving lines of a 2D array to a second 2D array based on a condition
Replies
3
Views
281
Peter_SSs
Peter_SSs
M
  • Solved
Add item to next cell on button click (with limited cells to use)
Replies
4
Views
393
mrfahaji
M
S
  • Question
analyze and export based on multiple criteria
Replies
0
Views
345
slash32487
S
D
  • Question
Code taking too long to run, unsure of the cause or the resolution
Replies
3
Views
348
offthelip
O
R
  • Solved
VBA in Excel to find free appointment in Outlook and display in an email
Replies
8
Views
2K
RockEd
R

Forum statistics

Threads
1,215,071
Messages
6,122,964
Members
449,094
Latest member
Anshu121

Share this page

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