Background: I have a table with rows of Staff IDs and columns of shifts (two a day: AM and PM). Staff indicate whether they can attend each shift. I then run a module that generates lists of all IDs who can attend each shift.
Question: Is there a module that can take that list of potential attendees for each shift and generate four random IDs for each AM shift and three random IDs for each PM shift?
The PM shift should not have the same IDs as the AM shift for each day.
Image 1: enter link description here
Image 2: enter link description here
This will do it - It's flexible on the number of employees available (can be 10, can be 50!) but it does assume 3 things:
The list of employees starts on row 3 with no blanks in this list
The Monday - Friday column C to column L
The 1st row will indicate whether it's an AM or PM shift
Option Explicit
Sub Work_timetables()
Dim c As Integer, R As Long, iEmployees As Long, ID As String, iField As Integer, bAM As Boolean, lRandomNumber As Long, iNumbersNeeded As Integer, iPicked As Integer
Application.ScreenUpdating = False
c = 3
R = 2
iField = 1
iEmployees = Range("B3:B" & Range("B3").End(xlDown).Row).Rows.Count
Do Until c > 12
Range("C2:L" & iEmployees + 2).AutoFilter Field:=iField, Criteria1:="Yes"
Range("B3:B" & Range("B3").End(xlDown).Row).Copy
Cells(iEmployees + 4, c).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("C2:L" & iEmployees).AutoFilter
c = c + 1
iField = iField + 1
Loop
c = 3
Start:
Do Until c > 12
If c Mod 2 = 0 Then
bAM = False
iNumbersNeeded = 3
End If
If Not c Mod 2 = 0 Then
bAM = True
iNumbersNeeded = 4
End If
If (Cells(1048563, c).End(xlUp).Row - (iEmployees + 3)) < iNumbersNeeded Then
MsgBox "There isn't enough emplooyees available for the " & Cells(2, c).Value & " (" & Cells(1, c).Value & ") shift" & vbNewLine & vbNewLine & "Moving to next shift", vbOKOnly, "Short staffed!"
c = c + 1
GoTo Start
End If
Do Until iPicked = iNumbersNeeded
goLoop:
lRandomNumber = WorksheetFunction.RandBetween(iEmployees + 4, Cells(iEmployees + 4, c).End(xlDown).Row)
If Trim(Range("B" & lRandomNumber).Value) = "" Then
Range("B" & lRandomNumber).Value = "Picked"
Cells(Range("C" & iEmployees + 4).CurrentRegion.Rows.Count + iEmployees + 6 + iPicked, c).Value = Cells(lRandomNumber, c)
iPicked = iPicked + 1
Else
GoTo goLoop
End If
Loop
Range("B" & iEmployees + 4 & ":B" & Range("C" & iEmployees + 4).CurrentRegion.Rows.Count + iEmployees + 4).ClearContents
c = c + 1
iPicked = 0
Loop
Application.ScreenUpdating = True
End Sub
Related
First of all thanks for helping me.
I programmed a Sub and I always get an Overflow fault 6. Its in the line where it says While x<160. I cannot do more then 160. E.g. If I do 170 Ill get the fault. But I would like to do While x<1000
The goal is to sum up duration times. Eg. On 1/2/2017 we had 2 downtime for electrical reason, first was 2 minutes, second was 10 minutes.
This macro is making a summary for the 1/2/17 saying that we had 12min downtime because electrical reasons.
I don't do that in a professional way, but this would make my work so much easier! Its working. I only get this annoying Overflow fault if I want to write in large numbers.
Sub sumuptheduration()
'Then sum up all the duration times
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim x As Long
Dim summe As Variant
Dim valuecells As Range
a = 1
b = 2
c = 0
x = 1
Set valuecells = Worksheets(1).Range("P2")
Do While Worksheets(1).Range("C" & b).Value = Worksheets(1).Range("C" & b+a).Value And Worksheets(1).Range("J" & b).Value = Worksheets(1).Range("J" & b + a).Value
Set valuecells = Worksheets(1).Range("P" & b & ":P" & a + b)
a = a + 1
Loop
Worksheets(1).Range("S" & a + (b - 1)).Value = Application.WorksheetFunction.Sum(valuecells)
b = a + 2
c = a + 2
a = 1
Dim y As Integer
y = 0
While x < 160
Do While Worksheets(1).Range("C" & b).Value = Worksheets(1).Range("C" & b + a).Value And Worksheets(1).Range("J" & b).Value = Worksheets(1).Range("J" & b + a).Value
Set valuecells = Worksheets(1).Range("P" & b & ":P" & c + a)
a = a + 1
Loop
Worksheets(1).Range("S" & c + (a - 1)).Value = Application.WorksheetFunction.Sum(valuecells) 'Writes the Sum into the correct Cell (last one of combination)
'This if clause checks if there are "Single combinations" because single combinations do not go through the do while at the top
If Worksheets(1).Range("J" & b).Value <> Worksheets(1).Range("J" & b + a).Value And Worksheets(1).Range("J" & b).Value <> Worksheets(1).Range("J" & b + (a - 2)).Value Or Worksheets(1).Range("C" & b).Value <> Worksheets(1).Range("C" & b + a).Value And Worksheets(1).Range("C" & b).Value <> Worksheets(1).Range("C" & b + (a - 2)).Value Then
Worksheets(1).Range("S" & b).Value = Worksheets(1).Range("P" & b).Value
Else
End If
'Change the variables into correct way for the next passing of the do while clause
x = x + 1 'causes that do while is not just one time passes
b = c + a
c = c + a 'temporary variable to not forget the old b during the next passing of the do while
a = 1 'at the end of every passing a tells you how much times you needed to pass the do while, so you have to reset it every time
Wend
End Sub
here
Change the declarations as follows:
Dim a As Long
Dim b As Long
Dim c As Long
Do not declare these variables as Integer
Please have a look at the following given code. It does the work but the code gives the values including the duplicates. (see the output)
I couldn't figure out how to extract unique vales instead of duplicates.
S.No Values
1 99.501
2 99.441
3 99.346
4 99.683
5 99.683
6 99.941
7 99.326
8 99.315
9 99.326
10 99.564
11 99.565
12 99.513
13 99.396
14 99.676
15 99.083
16 99.083
17 98.886
18 99.129
19 99.129
20 99.73
My code:
Sub MaxMin()
Dim Rng As Range, Dn As Range, Lg As String
Dim n As Long, c As Long, nRay As Variant
Dim Sm As String, Sp As Variant, ac As Long
Dim col As Integer, R As Long, t
Set Rng = Range(Range("b2"), Range("b" & Rows.Count).End(xlUp))
For n = 1 To 5
Lg = Lg & IIf(Lg = "", Application.Large(Rng, n), "," _
& Application.Large(Rng, n))
Sm = Sm & IIf(Sm = "", Application.Small(Rng, n), "," _
& Application.Small(Rng, n))
Next n
Sp = Array(Split(Lg, ","), Split(Sm, ","))
ReDim Ray(1 To 11, 1 To 4)
Ray(1, 1) = "S.No"
Ray(1, 2) = "Max"
Ray(1, 3) = "S.No"
Ray(1, 4) = "Min"
For ac = 0 To 1
col = IIf(ac = 0, 1, 3)
c = 0
nRay = Range(Range("A2"), Range("b" & Rows.Count).End(xlUp)).Resize(, 2)
c = 1
For n = 0 To 4
For R = 1 To UBound(nRay, 1)
If Not IsEmpty(nRay(R, 2)) And nRay(R, 2) = Val(Sp(ac)(n)) Then
c = c + 1
Ray(c, col) = nRay(R, 1)
Ray(c, col + 1) = nRay(R, 2)
nRay(R, 2) = ""
Exit For
End If
Next R
Next n
Next ac
Range("F1").Resize(6, 4).Value = Ray
End Sub
Output:
S.No Max S.No Min
6 99.941 17 98.886
20 99.73 15 99.083
4 99.683 16 99.083
5 99.683 18 99.129
14 99.676 19 99.129
The modified code should not include "duplicate" only "unique" 5 max and 5 min values with their index positions.
You can use Dictionary Object to get such results which QHarr is referring to like below.
Public Sub GetMinMax()
Dim objDict As Object
Dim i As Long
Set objDict = CreateObject("Scripting.Dictionary")
'\\ Add uniques to list
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Not objDict.exists(Range("B" & i).Value) Then objDict.Add Range("B" & i).Value, Range("A" & i).Value
Next
'\\ Populate output columns
Range("F1").Resize(1, 4).Value = Array("S.No.", "Max", "S.No.", "Min")
For i = 1 To 5
Range("G" & i + 1).Value = Application.Large(objDict.keys, i)
Range("F" & i + 1).Value = objDict.Item(Range("G" & i + 1).Value)
Range("I" & i + 1).Value = Application.Small(objDict.keys, i)
Range("H" & i + 1).Value = objDict.Item(Range("I" & i + 1).Value)
Next
End Sub
Here is what trouble me:
For cells in column P, for example P3, if both P2 & B3 is not blank, but P3 is blank, then merge P2 with P3. And go on next cell in column P until respective cell in column B(for instance: B8) is blank, then stop.
B .... P
1 Monitor Tom
2 Mouse Ann
3 Keyboard
4 Sticker
5 Speaker John
6 Cable
7 Fan Rose
8
So for table above, I want to merge P2:P4 & P5:P6.
I've tried several time with my poor vba skill, but failed...
This code is what I've found in this website, and I've tried to edit it and see if this can solve my problem, but it doesn't work...
Sub Merge()
LR = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To LR
If ActiveSheet.Cells(i, 1).Value <> "" And ActiveSheet.Cells(i + 1, 1).Value = "" And ActiveSheet.Cells(i + 1, 2).Value <> "" Then
u = i + 1
Do While ActiveSheet.Cells(u, 1).Value = "" And ActiveSheet.Cells(u, 2) <> ""
u = u + 1
Loop
ActiveSheet.Range("A" & i & ":A" & (u - 1)).Select
With Selection
.Merge
.BorderAround Weight:=xlMedium
.WrapText = True
'.VerticalAlignment = x1VAlignTop
'.HorizontalAlignment = xlLeft
End With
Sheets(DataSheet).Range("B" & i & ":B" & (u - 1)).BorderAround Weight:=xlMedium
i = u + 1
End If
Next i
End Sub
Try this:
Dim i As Integer, a As String, b As String, c As Integer, d As Integer
i = 11
a = "B"
b = "P"
c = 0
d = 0
While Range(a & i) <> ""
If Range(b & i) = "" Then
If c = 0 And i > 1 Then
c = i - 1
d = 1
Else
d = d + 1
End If
Else
If c > 0 And d > 0 Then
Range(b & c & ":" & b & (c + d)).Merge
End If
c = 0
d = 0
End If
i = i + 1
Wend
If c > 0 And d > 0 Then
Range(b & c & ":" & b & (c + d)).Merge
End If
I'm trying to copy values from one small sheet "MD with ID" to A Larger sheet "D with ID" if 2 fields are identical (consider those two as keys that identify each record).
Here is my first try:
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Here is my second try:
Sub CopyIDCells2()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 1
j = 2
Do Until j = 20886
d = 2
Do Until d = 1742
If e.Cells(j, 3).Value = i.Cells(d, 4).Value Then
If e.Cells(j, 13).Value = i.Cells(d, 10).Value Then
e.Cells(j, 1).Value = i.Cells(d, 2).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Nothing changes in the excel sheet when this code runs, although it takes few minutes to run -_-".
.. sample was removed
So looking at your first CopyIdCells method, there is only one fix I would make to this - make variable d=2. This has headers at the top of your sample data and you need to start on row 2 just like the other sheet.
Sub CopyIDCells()
Set i = Sheets("MD with ID")
Set e = Sheets("D with ID")
Dim d
Dim j
d = 2
j = 2
Do Until IsEmpty(e.Range("B" & j))
d = 2
Do Until IsEmpty(i.Range("A" & d))
If e.Range("C" & j).Value = i.Range("D" & d).Value Then
If e.Range("M" & j).Value = i.Range("J" & d).Value Then
e.Range("A" & j).Value = i.Range("B" & d).Value
End If
End If
d = d + 1
Loop
j = j + 1
Loop
End Sub
Other than that your formulas look good, you just do not have any data that meets your requirements. Add this column to the bottom of "MD with ID" and you will see your code match.
mouse 10 08 11267 A/J M 823 1/11/2008 1 SC-807 LONG 10/10/2005
Since you are matching on "Case Number" AND "Other ID" there are no items in both sheets that meet this criteria. When you add the row above to "MD with ID", you will see the appropriate ID added to your second sheet on several rows.
I have a column which consists of 3 digit codes referring to a branch. If a person is working in multiple departments, then he/she will have multiple codes referred in that column. Below is what it would look like.
Name | Branch
ABC | 423
MNO | 367325
XYZ | 414426429
I want it to look like this.
Name | Branch
ABC | 423
MNO | 367
MNO | 325
XYZ | 414
XYZ | 426
XYZ | 429
I want to extract the value of the cell, suppose let's say the string length is 9, then that person works for 3 branches. I want to extract those 3 values and duplicate the entire row with each row containing one branch number.
A few pointers : No person can work for more than 3 branches(so maximum string length will be 9). There are about 20 columns. The column which contains the branch codes is always the same i.e. column G. The column also has empty cells and other string values like 'BIKCJHGT'. The entire column is formatted as text.
Can any one please give me the VBA code to accomplish this?
Here is the code I've used. It hasn't thrown any errors, but it's not working either.
Option Explicit
Sub MultiRecords()
Dim b As Workbook
Set b = Workbooks.Open("C:\Users\uspola00\Desktop\Headcount_Final.xlsx")
ActiveWorkbook.Sheets("Headcount").Activate
ActiveSheet.Range("G1").Select
Dim ws As Worksheet
Set ws = Sheets("Headcount")
Dim intInsertRows As Integer
Dim i As Long
i = 1
Application.ScreenUpdating = False
Do Until i > ws.Range("G" & Rows.Count).End(xlUp).Row
Dim str As String
str = LTrim(RTrim(ws.Range("G" & i)))
If Len("G" & i) = 9 Then
intInsertRows = 2
Range("G" & i + 1 & ":G" & i + intInsertRows).EntireRow.Insert
Range("A" & i & ":N" & (i + intInsertRows)).FillDown
Range("G" & (i + intInsertRows)).Value = Right(str, 3)
Range("G" & i + 1).Value = Mid(str, 4, 3)
Range("G" & i).Value = Left(str, 3)
i = i + intInsertRows
ElseIf Len("G" & i) = 6 Then
intInsertRows = 1
Range("G" & i & ":G" & i + intInsertRows).EntireRow.Insert
Range("A" & i & ":N" & (i + intInsertRows)).FillDown
Range("G" & i + intInsertRows).Value = Right(str, 3)
Range("G" & i).Value = Left(str, 3)
i = i + intInsertRows
ElseIf Len("G" & i) = 3 Then
intInsertRows = 0
i = i + intInsertRows
ElseIf IsEmpty(Range("G" & i)) Then
i = i + 0
End If
i = i + 1
Loop
End Sub
Try this:
Sub MultiRecords()
Dim b As Workbook
Dim ws As Worksheet
Dim c As Range, v, i As Long
Set b = Workbooks.Open("C:\Users\uspola00\Desktop\Headcount_Final.xlsx")
Set ws = b.Sheets("Headcount")
Set c = ws.Cells(Rows.Count, "G").End(xlUp)
Do
v = Trim(c.Value)
If v Like "######" Or v Like "#########" Then
i = Len(v) / 3
c.Offset(1, 0).Resize(i - 1).EntireRow.Insert
c.Resize(i).EntireRow.FillDown
c.Value = Left(v, 3)
c.Offset(1, 0).Value = Mid(v, 4, 3)
If Len(v) = 9 Then c.Offset(2, 0).Value = Right(v, 3)
End If
If c.Row = 1 Then Exit Do
Set c = c.Offset(-1, 0)
Loop
End Sub