Count of Shift Combinations within a List of 100 continuous Shifts
This answer is a solution to the revised requirements of the asker.
I’m posting this answer as the asker changed the original requirements, and therefore requiring a different solution than the first posted. I decide to leave both solutions for the benefit of other users that might face any of these situations.
Requirements : There are 11 Shifts named from a to k we have a list of 100 turns taken by each shift. The objective is to count how many shift combinations are in the list i.e. How many times the Shift changes from: a to b and b to a, a to c and c to a, … j to k and k to j. Shifts are continual i.e. Row 2 is the continuation of Row 1 and Cell 1 is the continuation of Cell 100.
Assumptions : The list of shifts is located in the range L11:U21 with the results posted range AG10:AS22 (change as required)
The code below produces the required count of Shift Combinations and additionally a count of the Shifts Turns (see Fig. 1)
Users interested in having a deeper understanding of the resources used in the code are invited to visit these pages:
Variables & Constants, Excel Objects, With Statement,
For…Next Statement, For Each…Next Statement, GoSub…Return Statement,
Split Function, Custom Number Format, Range Properties (Excel)
I have also included some comments in the code indicating the purpose of each segment within it. Nevertheless, do let me know of any questions about the code and the resources used in it. Happy reading!!!
Option Explicit
Sub Shifts_Combinations_Count()
Const kShifts As String = "a,b,c,d,e,f,g,h,i,j,k"
Dim rSrc As Range, rTrg As Range
Dim sFmlR1C1 As String, sRef1 As String, sRef2 As String, sRef3 As String
Dim rTmp As Range, sShifts As String, iCol As Integer
Dim blFntBld As Boolean, blNbrFmt As Boolean
Dim b1 As Byte, b2 As Byte
Dim sLabel As String
Application.ScreenUpdating = False
Rem Set Ranges
With ThisWorkbook.Sheets("Sht(2)") 'Change the name of the worksheet as required
Set rSrc = .Range("L11:U20") 'Update the range as required
Set rTrg = .Range("AH11:AR21") 'Update the range as required
End With
Rem Builts Shift Combinations
With rSrc
Rem Add First Combinations
sShifts = "|" & .Cells(1).Value2 & .Cells(.Cells.Count).Value2 & "|"
Rem Add Combinations by Row
For iCol = 1 To .Columns.Count - 1
For Each rTmp In .Columns(iCol).Cells
With rTmp
sShifts = sShifts & .Value2 & .Offset(0, 1).Value2 & "|"
End With: Next: Next
Rem Add Combinations Cross Rows
For b1 = 1 To -1 + .Rows.Count
sShifts = sShifts & .Cells(b1, .Columns.Count).Value2 & _
.Cells(1 + b1, 1).Value2 & "|"
Next: End With
Rem Calculate Combinations
With rTrg
Rem Set Titles Rows
Set rTmp = .Rows(1).Offset(-1, 0)
blFntBld = 1: GoSub Rng_Formatting
rTmp.Value = Split(kShifts, Chr(44))
rTmp.ColumnWidth = 5
Rem Set Titles Cols
Set rTmp = .Columns(1).Offset(0, -1)
blFntBld = 1: GoSub Rng_Formatting
rTmp.Value = Application.Transpose(Split(kShifts, Chr(44)))
Rem Counting Combinations
Set rTmp = .Cells
blNbrFmt = 1: GoSub Rng_Formatting
sRef1 = .Cells(1).Offset(-1, -1).Address(1, 1, xlR1C1)
sRef2 = .Cells(1).Offset(0, -1).Address(0, 1, xlR1C1, , .Cells(1))
sRef3 = .Cells(1).Offset(-1, 0).Address(1, 0, xlR1C1, , .Cells(1))
Set rTmp = .Cells(1).Offset(-1, -1)
sLabel = rTmp.Value2
Rem rTmp.Font.Color = RGB(255, 255, 255)
rTmp.Value = sShifts
sFmlR1C1 = "=( LEN( " & sRef1 & " )" & _
"- LEN( SUBSTITUTE( SUBSTITUTE( " & sRef1 & _
"," & sRef2 & " & " & sRef3 & ", """" )" & _
"," & sRef3 & " & " & sRef2 & ", """" ) ) ) / 2"
.FormulaR1C1 = sFmlR1C1
Rem Clear Redundant Cells
For b1 = 1 To 11
For b2 = 1 To 11
If b2 >= b1 Then
With .Cells(b1, b2)
.ClearContents
.Borders.LineStyle = xlNone
.Interior.Color = RGB(216, 216, 216)
End With: End If: Next: Next
Rem Total Shifts
Set rTmp = .Columns(1 + .Columns.Count)
GoSub Rng_Formatting
sRef1 = rSrc.Address(1, 1, xlR1C1)
sRef2 = .Cells(1).Offset(0, -1).Address(0, 1, xlR1C1, , .Cells(1))
sFmlR1C1 = "=COUNTIF( " & sRef1 & ", " & sRef2 & " )"
rTmp.FormulaR1C1 = sFmlR1C1
Rem Grand Total Shifts
sFmlR1C1 = "=CONCATENATE( ""Shifts: "" , CHAR(10) , " & _
"SUM( " & rTmp.Address(1, 0, xlR1C1, , rTmp.Cells(1)) & ") )"
Set rTmp = rTmp.Cells(1).Offset(-1, 0)
blFntBld = 1: GoSub Rng_Formatting
GoSub Grand_Totals
rTmp.ColumnWidth = 6
Rem Total Combinations
Set rTmp = .Rows(1 + .Columns.Count)
GoSub Rng_Formatting
sRef1 = .Columns(1).Address(1, 0, xlR1C1, , .Cells(1))
sFmlR1C1 = "=SUM( " & sRef1 & " )"
rTmp.FormulaR1C1 = sFmlR1C1
Rem Grand Total Combinations
sFmlR1C1 = "=CONCATENATE( ""Combinations: "" , CHAR(10) , " & _
"SUM( " & rTmp.Address(0, 1, xlR1C1, , rTmp.Cells(1)) & ") )"
Set rTmp = rTmp.Cells(1).Offset(0, -1)
blFntBld = 1: GoSub Rng_Formatting
GoSub Grand_Totals
rTmp.ColumnWidth = 13
Rem Replace Formulas with values
.Calculate
.Value = .Value2
Rem Reset Title
Set rTmp = .Cells(1).Offset(-1, -1)
rTmp.Value = sLabel
Rem blFntBld = 1: GoSub Rng_Formatting
Rem rTmp.Font.ColorIndex = xlAutomatic
End With
Application.ScreenUpdating = 1
Exit Sub
Rng_Formatting:
Rem Range Formating
With rTmp
.Interior.Color = RGB(255, 255, 255)
If blNbrFmt Then .NumberFormat = " # ; -# ;"""";@"
If blFntBld Then .Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders.LineStyle = xlContinuous
.Borders.Color = RGB(128, 128, 128)
.BorderAround Weight:=xlMedium, Color:=RGB(128, 128, 128)
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
blNbrFmt = 0
blFntBld = 0
Return
Grand_Totals:
Rem Grand Totals Formatting
With rTmp
.FormulaR1C1 = sFmlR1C1
.Columns.AutoFit
.WrapText = True
.Rows.AutoFit
End With
Return
End Sub
Hope you find this answer useful, even if there are some things you don’t quite understand as of now, and hopefully those new things will spark the interest, curiosity in you and motivates you to know more about programming.
5
solved Need help in VBA