Option Explicit
Sub SummariseCodes_WithColours()
Dim shtInput As Worksheet
Dim colDataFirst As Long
Dim rowLast As Long
Dim rngData As Range, rngHdg As Range, rngOut As Range
Dim arrData As Variant, arrHdg As Variant
Dim arrTemp As Variant, arrOut As Variant, arrOutColor As Variant
Dim iRow As Long, iCol As Long
Dim colCnt As Long
Dim colCntMax As Long
Dim iTemp As Long
Dim curCode As String, curEndYr As String, prevStartYr As String
Dim iOutCol As Long
Dim k As Long
' Single cell range used to loop values transferred.
Dim rCell As Range '<= added
' "Output" worksheet into which the summary data is copied.
Dim wsOutputSheet As Worksheet '<= added
' Point worksheet object shtInput to the Input worksheet.
Set shtInput = Worksheets("Input")
' Point worksheet object wsOutputSheet to the output worksheet.
Set wsOutputSheet = Worksheets("Sheet1")
With shtInput
rowLast = .Range("A" & Rows.count).End(xlUp).Row
Set rngData = .Range("c2:En" & rowLast)
' Find the year column from the left that has data
colDataFirst = rngData.Cells.Find("*", , xlFormulas, , xlByColumns, xlNext).Column
' Change rngData to reduce the size to just the columns with data
Set rngData = .Range(.Cells(2, colDataFirst), .Cells(rowLast, "EO"))
Set rngHdg = rngData.Resize(1).Offset(-1)
arrHdg = rngHdg
arrData = rngData
' Add a blank column to simplify logic
ReDim Preserve arrData(1 To UBound(arrData, 1), 1 To UBound(arrData, 2) + 1)
ReDim Preserve arrHdg(1 To UBound(arrHdg, 1), 1 To UBound(arrHdg, 2) + 1)
Set rngOut = .Range("ER2")
End With
ReDim arrTemp(1 To UBound(arrData, 2), 1 To 4) As Variant ' XXX Added a column to capture colour
ReDim arrOut(1 To UBound(arrData), 1 To 40) As String
colCnt = 0
iTemp = 1
curCode = ""
For iRow = 1 To UBound(arrData)
For iCol = 1 To UBound(arrData, 2)
If (iCol = 1 And arrData(iRow, iCol) <> "") _
Or (iCol <> 1 And arrData(iRow, iCol) <> curCode) Then
curCode = arrData(iRow, iCol)
curEndYr = arrHdg(1, iCol)
If iTemp <> 1 Then
prevStartYr = arrHdg(1, iCol - 1)
arrTemp(iTemp - 1, 2) = prevStartYr
End If
If curCode <> "" Then
colCnt = colCnt + 1
arrTemp(iTemp, 1) = curCode
arrTemp(iTemp, 3) = curEndYr
arrTemp(iTemp, 4) = rngData(iRow, iCol).Interior.Color ' XXX Added to capture colour
iTemp = iTemp + 1
End If
End If
Next iCol
If colCnt > colCntMax Then
colCntMax = colCnt
If UBound(arrOut, 2) < colCntMax * 2 Then
ReDim Preserve arrOut(1 To UBound(arrData), 1 To colCntMax * 2) As String
End If
End If
' Transpose arrTemp into Output format and concatenate from & to year
iOutCol = 1
For k = 1 To colCnt
arrOut(iRow, iOutCol) = arrTemp(k, 1)
arrOut(iRow, iOutCol + 1) = arrTemp(k, 2) & "-" & arrTemp(k, 3)
' Apply BackGround Colour
rngOut.Offset(iRow - 1, iOutCol - 1).Interior.Color = arrTemp(k, 4)
rngOut.Offset(iRow - 1, iOutCol + 1 - 1).Interior.Color = arrTemp(k, 4)
' Put interior color into summary results cells in output worksheet.
With wsOutputSheet.Range("C2")
.Offset(iRow - 1, iOutCol - 1).Interior.Color = arrTemp(k, 4)
.Offset(iRow - 1, iOutCol + 1 - 1).Interior.Color = arrTemp(k, 4)
End With
iOutCol = iOutCol + 2
Next k
' Zero out arrTemp
ReDim arrTemp(1 To UBound(arrTemp, 1), 1 To UBound(arrTemp, 2)) As String
colCnt = 0
iTemp = 1
Next iRow
Set rngOut = rngOut.Resize(UBound(arrOut), colCntMax * 2)
' Put TEMPORARY summary results into the Input worksheet. These
' results willbe deleted after they are transferred into the output worksheet.
rngOut = arrOut
' --------------------------
' Code Added
' --------------------------
' Clear existing data in the output worksheet.
wsOutputSheet.Cells.Clear
' Copy school names in Input worksheet into the output worksheet.
shtInput.Range("A1").Resize(UBound(arrOut) + 1, 2).Copy wsOutputSheet.Range("A1")
' Format new header cells in the output worksheet.
With wsOutputSheet
' Width of ID column.
.Range("A1").ColumnWidth = 7
' Width of column containing school names.
.Range("B1").ColumnWidth = 57
With .Range("C1:H1")
.ColumnWidth = 15
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
With .Font
.Name = "Arial"
.Size = 11
.Bold = True
End With
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249946592608417
.PatternTintAndShade = 0
End With
End With
' Put column headers for Conference into the respective columns in the output worksheet.
.Range("C1").Value = "Conference"
.Range("E1").Value = "Conference"
.Range("G1").Value = "Conference"
' Put column headers for Years into the respective columns in the output worksheet.
.Range("D1").Value = "Years"
.Range("F1").Value = "Years"
.Range("H1").Value = "Years"
' If the command/form button was copied into the output worksheet then delete it.
On Error Resume Next
.Shapes.Range(Array("SummarizeWithColors_Button")).Delete
On Error GoTo 0
End With
' Copy the summary results into the output worksheet.
rngOut.Copy wsOutputSheet.Range("C2")
' Loop all data transferred to the output worksheet and remove fill (interior color)
' for any cells that are empty.
For Each rCell In wsOutputSheet.Range("C2").Resize(UBound(arrOut) + 1, colCntMax * 2)
If rCell.Value = "" Then rCell.Interior.Color = xlNone
Next rCell
' Clear cell contents and interior colors for "temporary" results range in Input sheet.
rngOut.Value = ""
rngOut.Interior.Color = xlNone
End Sub
