Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.
Sub FillBids()
Dim dctRoute As Dictionary
Set dctRoute = New Dictionary
Dim arrRoute(50) As String
Dim arrMax(50) As Integer
Dim arrCount(50) As Integer
Application.ScreenUpdating = False
numBidRows = Sheets("ALL BIDS").Range("A10000").End(xlUp).Row
For Each c In [myRoutes]
x = x + 1
dctRoute.Add c.Value, x
arrRoute(x) = c.Value
arrMax(x) = c.Offset(0, 10).Value ' this is where I get the total number of people
' I'm trying to fill
Next c
myTotal = 0
For j = 2 To numBidRows
Application.StatusBar = "Processing seniority position " & Sheets("ALL BIDS").Cells(j, 1).Value & " ..."
For k = 1 To 14 'num of bids per person
thisRoute = Sheets("ALL BIDS").Cells(j, k + 4).Value
If thisRoute <> "NULL" Then
If arrCount(dctRoute(thisRoute)) < arrMax(dctRoute(thisRoute)) Then
arrCount(dctRoute(thisRoute)) = arrCount(dctRoute(thisRoute)) + 1
For m = 1 To 19
Sheets(thisRoute).Cells(arrCount(dctRoute(thisRoute)) + 1, m + 1) = Sheets("ALL BIDS").Cells(j, m).Value
Next m
Exit For
End If
Else
'Sheets(thisRoute).Range(Cells(j, 1), Cells(j, 15)).Interior.ColorIndex = 3 ' this would do the whole row
Sheets("ALL BIDS").Cells(j, 4).Interior.ColorIndex = 3 ' this does just the name column
End If
Next k
Next j
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub FillBids()
Dim dctRouteMax As Dictionary
Set dctRouteMax = New Dictionary
Dim dctRouteReduction As Dictionary
Set dctRouteReduction = New Dictionary
Application.ScreenUpdating = False
numBidRows = Sheets("ALL BIDS").Range("A10000").End(xlUp).Row
strOldReductions = "Old reductions were:"
For Each c In [myRoutes]
dctRouteMax.Add c.Value, c.Offset(0, 10).Value ' this is where I get the total number of people I'm trying to fill
dctRouteReduction.Add c.Value, c.Offset(0, 8).Value ' this is where I get the total reduction for each route
strOldReductions = strOldReductions & vbCrLf & c.Value & ": " & c.Offset(0, 8).Value
Next c
blnNotAllAllocated = True
intAttempts = 0
Sheets("ALL BIDS").Range("D2:D10000").Clear
While blnNotAllAllocated = True And intAttempts < numBidRows * 14
blnNotAllAllocated = False
For j = 2 To numBidRows
intAttempts = intAttempts + 1
currentPosition = Sheets("ALL BIDS").Cells(j, 3).Value
Application.StatusBar = "Pass " & Int(intAttempts / numBidRows) + 1 & " of 14 - Processing seniority position " & Sheets("ALL BIDS").Cells(j, 1).Value & " ..."
If Sheets("ALL BIDS").Cells(j, 4).Value = "" Then blnNotAllAllocated = True
For k = 1 To 14 'num of bids per person
thisRoute = Sheets("ALL BIDS").Cells(j, k + 4).Value
If thisRoute <> "NULL" Then
If dctRouteReduction(thisRoute) < 0 Then
dctRouteReduction(thisRoute) = dctRouteReduction(thisRoute) + 1
dctRouteReduction(currentPosition) = dctRouteReduction(currentPosition) - 1
'For m = 1 To 19
' Sheets(thisRoute).Cells(dctRouteMax(thisRoute) + 1, m + 1) = Sheets("ALL BIDS").Cells(j, m).Value
'Next m
Sheets("ALL BIDS").Cells(j, 4).Value = Sheets("ALL BIDS").Cells(1, k + 4).Value & ": " & thisRoute
Exit For
End If
Else
'Sheets(thisRoute).Range(Cells(j, 1), Cells(j, 15)).Interior.ColorIndex = 3 ' this would do the whole row
'Sheets("ALL BIDS").Cells(j, 4).Interior.ColorIndex = 3 ' this does just the name column
End If
Next k
Next j
Wend
strNewReductions = "New reductions are:"
For Each strR In dctRouteReduction
strNewReductions = strNewReductions & vbCrLf & strR & ": " & dctRouteReduction(strR)
Next
MsgBox strNewReductions & vbCrLf & vbCrLf & strOldReductions
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub ClearTabs()
Sheets("All BIDS").Cells.Interior.ColorIndex = 0
For Each c In [myRoutes]
Sheets(c.Value).Range("A2:VV1000").ClearContents
Next c
End Sub
Sub FillBids()
Dim dctRouteMax As Dictionary
Set dctRouteMax = New Dictionary
Dim dctRouteReduction As Dictionary
Set dctRouteReduction = New Dictionary
Application.ScreenUpdating = False
numBidRows = Sheets("ALL BIDS").Range("A10000").End(xlUp).Row
strOldReductions = "Old reductions were:"
For Each c In [myRoutes]
dctRouteMax.Add c.Value, c.Offset(0, 10).Value ' this is where I get the total number of people I'm trying to fill
dctRouteReduction.Add c.Value, c.Offset(0, 8).Value ' this is where I get the total reduction for each route
strOldReductions = strOldReductions & vbCrLf & c.Value & ": " & c.Offset(0, 8).Value
Next c
blnNotAllAllocated = True
intAttempts = 0
Sheets("ALL BIDS").Range("D2:D10000").ClearContents
While blnNotAllAllocated = True And intAttempts < numBidRows * 14
blnNotAllAllocated = False
For j = 2 To numBidRows
intAttempts = intAttempts + 1
currentPosition = Sheets("ALL BIDS").Cells(j, 3).Value
Application.StatusBar = "Pass " & Int(intAttempts / numBidRows) + 1 & " of 14 - Processing seniority position " & Sheets("ALL BIDS").Cells(j, 1).Value & " ..."
If Sheets("ALL BIDS").Cells(j, 4).Value = "" Then blnNotAllAllocated = True
For k = 1 To 14 'num of bids per person
thisRoute = Sheets("ALL BIDS").Cells(j, k + 4).Value
If thisRoute <> "NULL" Then
If dctRouteReduction(thisRoute) > 0 Then
dctRouteReduction(thisRoute) = dctRouteReduction(thisRoute) - 1
dctRouteReduction(currentPosition) = dctRouteReduction(currentPosition) + 1
'For m = 1 To 19
' Sheets(thisRoute).Cells(dctRouteMax(thisRoute) + 1, m + 1) = Sheets("ALL BIDS").Cells(j, m).Value
'Next m
Sheets("ALL BIDS").Cells(j, 4).Value = Sheets("ALL BIDS").Cells(1, k + 4).Value & ": " & thisRoute
Exit For
End If
Else
'Sheets(thisRoute).Range(Cells(j, 1), Cells(j, 15)).Interior.ColorIndex = 3 ' this would do the whole row
'Sheets("ALL BIDS").Cells(j, 4).Interior.ColorIndex = 3 ' this does just the name column
End If
Next k
Next j
Wend
strNewReductions = "New reductions are:"
For Each strR In dctRouteReduction
strNewReductions = strNewReductions & vbCrLf & strR & ": " & dctRouteReduction(strR)
Next
MsgBox strNewReductions & vbCrLf & vbCrLf & strOldReductions
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub ClearTabs()
Sheets("All BIDS").Cells.Interior.ColorIndex = 0
For Each c In [myRoutes]
Sheets(c.Value).Range("A2:VV1000").ClearContents
Next c
End Sub
Sub FillBids()
Dim dctRouteMax As Dictionary
Set dctRouteMax = New Dictionary
Dim dctRouteReduction As Dictionary
Set dctRouteReduction = New Dictionary
Application.ScreenUpdating = False
numBidRows = Sheets("ALL BIDS").Range("A10000").End(xlUp).Row
strOldReductions = "Old reductions were:"
For Each c In [myRoutes]
dctRouteMax.Add c.Value, c.Offset(0, 10).Value ' this is where I get the total number of people I'm trying to fill
dctRouteReduction.Add c.Value, c.Offset(0, 8).Value ' this is where I get the total reduction for each route
strOldReductions = strOldReductions & vbCrLf & c.Value & ": " & c.Offset(0, 8).Value
Next c
blnNotAllAllocated = True
intAttempts = 0
Sheets("ALL BIDS").Range("D2:D10000").ClearContents
While blnNotAllAllocated = True And intAttempts < numBidRows * 14
blnNotAllAllocated = False
For j = 2 To numBidRows
intAttempts = intAttempts + 1
currentPosition = Sheets("ALL BIDS").Cells(j, 3).Value
Application.StatusBar = "Pass " & Int(intAttempts / numBidRows) + 1 & " of 14 - Processing seniority position " & Sheets("ALL BIDS").Cells(j, 1).Value & " ..."
If Sheets("ALL BIDS").Cells(j, 4).Value = "" Then
blnNotAllAllocated = True
For k = 1 To 14 'num of bids per person
thisRoute = Sheets("ALL BIDS").Cells(j, k + 4).Value
If thisRoute <> "NULL" Then
If dctRouteReduction(thisRoute) > 0 Then
dctRouteReduction(thisRoute) = dctRouteReduction(thisRoute) - 1
dctRouteReduction(currentPosition) = dctRouteReduction(currentPosition) + 1
'For m = 1 To 19
' Sheets(thisRoute).Cells(dctRouteMax(thisRoute) + 1, m + 1) = Sheets("ALL BIDS").Cells(j, m).Value
'Next m
Sheets("ALL BIDS").Cells(j, 4).Value = Sheets("ALL BIDS").Cells(1, k + 4).Value & ": " & thisRoute
Exit For
End If
Else
'Sheets(thisRoute).Range(Cells(j, 1), Cells(j, 15)).Interior.ColorIndex = 3 ' this would do the whole row
'Sheets("ALL BIDS").Cells(j, 4).Interior.ColorIndex = 3 ' this does just the name column
End If
Next k
End If
Next j
Wend
strNewReductions = "New reductions are:"
For Each strR In dctRouteReduction
strNewReductions = strNewReductions & vbCrLf & strR & ": " & dctRouteReduction(strR)
Next
MsgBox strNewReductions & vbCrLf & vbCrLf & strOldReductions
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub ClearTabs()
Sheets("All BIDS").Cells.Interior.ColorIndex = 0
For Each c In [myRoutes]
Sheets(c.Value).Range("A2:VV1000").ClearContents
Next c
End Sub
Sub FillBids()
Dim dctRouteMax As Dictionary
Set dctRouteMax = New Dictionary
Dim dctRouteReduction As Dictionary
Set dctRouteReduction = New Dictionary
Application.ScreenUpdating = False
numBidRows = Sheets("ALL BIDS").Range("A10000").End(xlUp).Row
strOldReductions = "Old reductions were:"
For Each c In [myRoutes]
dctRouteMax.Add c.Value, c.Offset(0, 10).Value ' this is where I get the total number of people I'm trying to fill
dctRouteReduction.Add c.Value, c.Offset(0, 8).Value ' this is where I get the total reduction for each route
strOldReductions = strOldReductions & vbCrLf & c.Value & ": " & c.Offset(0, 8).Value
Next c
blnNotAllAllocated = True
intAttempts = 0
Sheets("ALL BIDS").Range("D2:D10000").ClearContents
While blnNotAllAllocated = True And intAttempts < numBidRows * 14
blnNotAllAllocated = False
For k = 1 To 14
For j = 2 To numBidRows
Application.StatusBar = "Processing Bid " & k & " of 14 - Processing seniority position " & Sheets("ALL BIDS").Cells(j, 1).Value & " ..."
intAttempts = intAttempts + 1
currentPosition = Sheets("ALL BIDS").Cells(j, 3).Value
If Sheets("ALL BIDS").Cells(j, 4).Value = "" Then
blnNotAllAllocated = True
thisRoute = Sheets("ALL BIDS").Cells(j, k + 4).Value
'MsgBox thisRoute & ": " & j & "," & k + 4
If thisRoute <> "NULL" Then
'MsgBox j & ", " & k + 4 & ": " & thisRoute & " spaces left " & dctRouteReduction(thisRoute)
If dctRouteReduction(thisRoute) > 0 Then
dctRouteReduction(thisRoute) = dctRouteReduction(thisRoute) - 1
dctRouteReduction(currentPosition) = dctRouteReduction(currentPosition) + 1
'For m = 1 To 19
' Sheets(thisRoute).Cells(dctRouteMax(thisRoute) + 1, m + 1) = Sheets("ALL BIDS").Cells(j, m).Value
'Next m
Sheets("ALL BIDS").Cells(j, 4).Value = Sheets("ALL BIDS").Cells(1, k + 4).Value & ": " & thisRoute
'Exit For
End If
Else
'Sheets(thisRoute).Range(Cells(j, 1), Cells(j, 15)).Interior.ColorIndex = 3 ' this would do the whole row
'Sheets("ALL BIDS").Cells(j, 4).Interior.ColorIndex = 3 ' this does just the name column
End If
End If
Next j
Next k
Wend
strNewReductions = "New reductions are:"
For Each strR In dctRouteReduction
strNewReductions = strNewReductions & vbCrLf & strR & ": " & dctRouteReduction(strR)
Next
MsgBox strNewReductions & vbCrLf & vbCrLf & strOldReductions
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub ClearTabs()
Sheets("All BIDS").Cells.Interior.ColorIndex = 0
For Each c In [myRoutes]
Sheets(c.Value).Range("A2:VV1000").ClearContents
Next c
End Sub
Now, another thing to clarify, when I go back to the original method:
"anyone currently in the position should still hold it"
Does that mean anyone who has Bid1 the same as their current position, that they should hold it no matter what....even if the TOTAL REDUCTION is negative? It currently doesn't work that way. It's currently designed to bring all reductions back to zero as close as possible.
Can you run that one again and see what the issues are?
For me to write the data to each of the route sheets, I'll need to understand what they're for. I'm currently confused by the fact that they all seem to have a mismatch of data on them. If they are to be populated with only each new bid that was successfull, then should they be placed on that sheet for their winning bid (which the value I currently write to column D on ALL BIDS)?
Sub FillBids()
Dim dctRouteMax As Dictionary
Set dctRouteMax = New Dictionary
Dim dctRouteCurrent As Dictionary
Set dctRouteCurrent = New Dictionary
Application.ScreenUpdating = False
numBidRows = Sheets("ALL BIDS").Range("A10000").End(xlUp).Row
strOldOnline = "Old online values were:"
For Each c In [myRoutes]
dctRouteMax.Add c.Value, c.Offset(0, 4).Value ' this is where I get the desired on line value
dctRouteCurrent.Add c.Value, 0
strOldOnline = strOldOnline & vbCrLf & c.Value & ": " & c.Offset(0, 2).Value
Sheets(c.Value).Rows("2:10000").Clear
Next c
Sheets("ALL BIDS").Range("T2:T10000").ClearContents
blnNotAllAllocated = False
For k = 1 To 14 'num of bids per person
For j = 2 To numBidRows
thisRoute = Sheets("ALL BIDS").Cells(j, k + 4).Value
Application.StatusBar = "Processing bid " & k & ". Processing seniority position " & Sheets("ALL BIDS").Cells(j, 1).Value & " ..."
If Sheets("ALL BIDS").Cells(j, "T").Value = "" Then
If thisRoute <> "NULL" Then
If dctRouteCurrent(thisRoute) < dctRouteMax(thisRoute) Then
dctRouteCurrent(thisRoute) = dctRouteCurrent(thisRoute) + 1
Sheets("ALL BIDS").Cells(j, "T").Value = Sheets("ALL BIDS").Cells(1, k + 4).Value & ": " & thisRoute
If thisRoute <> "NEW HIRE" Then
Sheets(thisRoute).Rows("2:2").Insert Shift:=xlDown
Sheets(thisRoute).Rows("2:2").Clear
Sheets("ALL BIDS").Range("A" & j & ":S" & j).Copy Sheets(thisRoute).Range("B2")
End If
End If
Else
'Sheets(thisRoute).Range(Cells(j, 1), Cells(j, 15)).Interior.ColorIndex = 3 ' this would do the whole row
'Sheets("ALL BIDS").Cells(j, 4).Interior.ColorIndex = 3 ' this does just the name column
End If
End If
Next j
Next k
strNewOnline = "New online values are:"
For Each strR In dctRouteCurrent
strNewOnline = strNewOnline & vbCrLf & strR & ": " & dctRouteCurrent(strR) & vbTab & "Max: " & dctRouteMax(strR)
If strR <> "NEW HIRE" Then
intRouteLastRow = Sheets(strR).Cells(65536, "B").End(xlUp).Row
Sheets(strR).Sort.SortFields.Clear
Sheets(strR).Sort.SortFields.Add Key:=Range("B2:B" & intRouteLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets(strR).Sort
.SetRange Sheets(strR).Range("B1:T" & intRouteLastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets(strR).Activate
Sheets(strR).Range("A1").Select
End If
Next
Sheets("ALL BIDS").Activate
'Sheets("ALL BIDS").Range("T2:T10000").ClearContents
MsgBox strNewOnline & vbCrLf & vbCrLf & strOldOnline
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub ClearTabs()
Sheets("All BIDS").Cells.Interior.ColorIndex = 0
For Each c In [myRoutes]
Sheets(c.Value).Range("A2:VV1000").ClearContents
Next c
End Sub
Sub FillBids()
Dim dctRouteMax As Dictionary
Set dctRouteMax = New Dictionary
Dim dctRouteCurrent As Dictionary
Set dctRouteCurrent = New Dictionary
Application.ScreenUpdating = False
numBidRows = Sheets("ALL BIDS").Range("A10000").End(xlUp).Row
strOldOnline = "Old online values were:"
For Each c In [myRoutes]
dctRouteMax.Add c.Value, c.Offset(0, 4).Value ' this is where I get the desired on line value
dctRouteCurrent.Add c.Value, c.Offset(0, 2).Value ' this is where I get the current on line value
strOldOnline = strOldOnline & vbCrLf & c.Value & ": " & c.Offset(0, 2).Value
Sheets(c.Value).Rows("2:10000").Clear
Next c
Sheets("ALL BIDS").Range("T2:T10000").ClearContents
j = 2
For k = 1 To 14 'num of bids per person
For j = 2 To numBidRows
thisRoute = Sheets("ALL BIDS").Cells(j, k + 4).Value
currentPosition = Sheets("ALL BIDS").Cells(j, "C").Value
Application.StatusBar = "Processing bid " & k & ". Processing seniority position " & Sheets("ALL BIDS").Cells(j, 1).Value & " ..."
If Sheets("ALL BIDS").Cells(j, "T").Value = "" Then
If thisRoute <> "NULL" Then
If thisRoute <> currentPosition Then
If dctRouteCurrent(thisRoute) < dctRouteMax(thisRoute) Then
dctRouteCurrent(thisRoute) = dctRouteCurrent(thisRoute) + 1
dctRouteCurrent(currentPosition) = dctRouteCurrent(currentPosition) - 1
Sheets("ALL BIDS").Cells(j, "T").Value = Sheets("ALL BIDS").Cells(1, k + 4).Value & ": " & thisRoute
If thisRoute <> "NEW HIRE" Then
Sheets(thisRoute).Rows("2:2").Insert Shift:=xlDown
Sheets(thisRoute).Rows("2:2").Clear
Sheets("ALL BIDS").Range("A" & j & ":S" & j).Copy Sheets(thisRoute).Range("B2")
End If
j = 2
k = 1
Exit For
End If
Else
If dctRouteCurrent(thisRoute) <= dctRouteMax(thisRoute) Then
Sheets("ALL BIDS").Cells(j, "T").Value = Sheets("ALL BIDS").Cells(1, k + 4).Value & ": " & thisRoute
If thisRoute <> "NEW HIRE" Then
Sheets(thisRoute).Rows("2:2").Insert Shift:=xlDown
Sheets(thisRoute).Rows("2:2").Clear
Sheets("ALL BIDS").Range("A" & j & ":S" & j).Copy Sheets(thisRoute).Range("B2")
End If
j = 2
k = 1
Exit For
End If
End If
Else
'Sheets(thisRoute).Range(Cells(j, 1), Cells(j, 15)).Interior.ColorIndex = 3 ' this would do the whole row
'Sheets("ALL BIDS").Cells(j, 4).Interior.ColorIndex = 3 ' this does just the name column
End If
End If
Next j
Next k
strNewOnline = "New online values are:"
For Each strR In dctRouteCurrent
strNewOnline = strNewOnline & vbCrLf & strR & ": " & dctRouteCurrent(strR) & vbTab & "Max: " & dctRouteMax(strR)
If strR <> "NEW HIRE" Then
intRouteLastRow = Sheets(strR).Cells(65536, "B").End(xlUp).Row
Sheets(strR).Sort.SortFields.Clear
Sheets(strR).Sort.SortFields.Add Key:=Range("B2:B" & intRouteLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets(strR).Sort
.SetRange Sheets(strR).Range("B1:T" & intRouteLastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets(strR).Activate
Sheets(strR).Range("A1").Select
End If
Next
Sheets("ALL BIDS").Activate
'Sheets("ALL BIDS").Range("T2:T10000").ClearContents
MsgBox strNewOnline & vbCrLf & vbCrLf & strOldOnline
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Sub ClearTabs()
Sheets("All BIDS").Cells.Interior.ColorIndex = 0
For Each c In [myRoutes]
Sheets(c.Value).Range("A2:VV1000").ClearContents
Next c
End Sub
Scrubbed-Version-V4.xlsm
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.