Option Explicit
Dim rWhole As Range
Dim rCell As Range
Dim aColours() As Long
Dim iCellCount As Integer
Dim Dictionary As Object
Dim v As Variant
Dim i As Integer
Dim j As Integer
Dim TempForm As Object
Dim NewButton As MSForms.CommandButton
Dim NewLabel As MSForms.Label
Dim NewCheckBox As MSForms.CheckBox
Dim iLine As Integer
Dim oForm As UserForm
Sub ReplaceColours(Optional Control As IRibbonControl)
iCellCount = 0
'Set the basic range to deal with as all of the used cells in the sheet
Set rWhole = ActiveSheet.Range("A1:" + ActiveSheet.UsedRange.Address)
On Error GoTo ErrChecker
For i = 1 To ActiveWorkbook.VBProject.VBComponents.Count
For j = 1 To 25
If ActiveWorkbook.VBProject.VBComponents(i).Name = "UserForm" & j Then
With ThisWorkbook.VBProject.VBComponents
.Remove .Item("Userform" & j)
End With
End If
Next j
Next i
CarryOn1:
'Cycle through the cells in the range, capturing the colour of that cell
For Each rCell In rWhole
'If the cell colour is not blank
If rCell.Interior.ColorIndex <> xlNone Then
'Add one to the count of coloured cells
iCellCount = iCellCount + 1
'increase the size of the holding array by one, without losing existing values
ReDim Preserve aColours(1 To iCellCount)
'Put the new colour into the added space in the array
aColours(iCellCount) = rCell.Interior.Color
Else
'Skip the cell - We may need to include the white cells later but no need to find them all
'at the moment.
End If
Next
Set Dictionary = CreateObject("Scripting.Dictionary")
For i = LBound(aColours) To UBound(aColours)
Dictionary(aColours(i)) = 1
Next i
'Application.VBE.MainWindow.Visible = False
Set TempForm = ThisWorkbook.VBProject.VBComponents.Add(3) '3 = vbext_ct_MSForm
With TempForm
.Properties("Caption") = "Colour Replacement"
.Properties("Width") = 6 + 90 + 4 + 12 + 4 + 90 + 10
.Properties("BackColor") = 16777215
End With
i = 0
'Dictionary.Keys() is an array of the unique colours in our colour array (as variants).
For Each v In Dictionary.Keys()
i = i + 1
'----------------------------------------------------------------------------------------------------------
'----Now that we can list all the colours, we want to make a user form with a series of coloured labels----
'----and tick boxes which the user will be able to use to select colours to replace. This will be the ----
'----basis for the replacement later ----
'----------------------------------------------------------------------------------------------------------
'Create Labels for each colour, filled with that colour
Set NewLabel = TempForm.designer.Controls.Add("Forms.label.1")
With NewLabel
.Name = "FieldLabel" & i
.Top = (12 * i) + 12
.Left = 6
.Width = 90
.Height = 12
.Font.Size = 7
.Font.Name = "Tahoma"
.BackColor = v
.BorderStyle = fmBorderStyleSingle
.BorderColor = 0
End With
'Create Checkbokes so the user can select which colours to replace, independently of the colour choice itself
Set NewCheckBox = TempForm.designer.Controls.Add("Forms.checkbox.1")
With NewCheckBox
.Name = "CheckBox" & i
.Top = (12 * i) + 12
.Left = 6 + 90 + 4
.Width = 12
.Height = 12
.Font.Size = 7
.Font.Name = "Tahoma"
End With
'Create Labels to display the new colour values with which to replace the old
Set NewLabel = TempForm.designer.Controls.Add("Forms.label.1")
With NewLabel
.Name = "FieldLabel" & i & "a"
.Top = (12 * i) + 12
.Left = 6 + 90 + 4 + 12 + 4
.Width = 90
.Height = 12
.Font.Size = 7
.Font.Name = "Tahoma"
.BorderStyle = fmBorderStyleSingle
.BorderColor = 0
End With
'Create Event Handler Code For Each New Colour Label
With TempForm.codemodule
iLine = .countoflines
'When you click on the label, it shows you the colour selection dialg and turns the selected colour
.insertlines iLine + 1, "Sub FieldLabel" & i & "a" & "_Click()"
.insertlines iLine + 2, "FieldLabel" & i & "a.BackColor = GetUserSelectedColor(" & aColours(i) & ")"
.insertlines iLine + 3, "CheckBox" & i & ".Value = True"
.insertlines iLine + 4, "End Sub"
End With
Next v
'--------------------------------------------------------------------------------------------
'------------------------------------ R E L O A D ----------------------------------------------
'Add a Reload button to allow the user to reload the current colours displayed on the userform
Set NewButton = TempForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "Reload"
.Caption = "Reload"
.Top = (12 * (i + 2)) + 12
.Height = 20
.Left = 6
.Width = 50
End With
With TempForm.codemodule
iLine = .countoflines
.insertlines iLine + 1, "Sub Reload_Click()"
.insertlines iLine + 2, "Unload Me"
.insertlines iLine + 3, "Call ReplaceColours"
.insertlines iLine + 4, "End Sub"
End With
'---------------------------------- R E P L A C E ----------------------------------------------
'add a Replace button to accept choices made
Set NewButton = TempForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "Replace"
.Caption = "Replace"
.Top = (12 * (i + 2)) + 12
.Height = 20
.Left = 6 + 50 + 6
.Width = 50
End With
With TempForm.codemodule
iLine = .countoflines
'Make two arrays - one of old colours to be changed and one of New colours
.insertlines iLine + 1, "Sub Replace_Click()"
.insertlines iLine + 2, " Dim aToBeReplaced() As Long"
.insertlines iLine + 3, " Dim aReplacements() As Long"
.insertlines iLine + 4, " Dim iChangeCount As Integer"
.insertlines iLine + 5, " Dim oControl As Control"
.insertlines iLine + 6, " Dim oControl1 As Control"
.insertlines iLine + 7, " Dim rWhole As Range"
.insertlines iLine + 8, " Dim rCell As Range"
.insertlines iLine + 9, " iChangeCount = 0"
.insertlines iLine + 10, " Set rWhole = ActiveSheet.Range(""A1:"" + ActiveSheet.UsedRange.Address)"
.insertlines iLine + 11, "For Each oControl in Me.Controls"
.insertlines iLine + 12, "On Error Resume Next"
.insertlines iLine + 13, " If TypeOf oControl Is MSForms.CheckBox Then"
.insertlines iLine + 14, " iChangeCount = iChangeCount + 1"
.insertlines iLine + 15, " If oControl.Value = True Then"
.insertlines iLine + 16, " ReDim Preserve aToBeReplaced(1 to iChangeCount)"
.insertlines iLine + 17, " ReDim Preserve aReplacements(1 to iChangeCount)"
.insertlines iLine + 18, " For Each oControl1 In Me.Controls"
.insertlines iLine + 19, " If TypeOf oControl1 Is MSForms.Label Then"
.insertlines iLine + 20, " If oControl1.Name = ""FieldLabel"" & iChangeCount Then"
.insertlines iLine + 21, " aToBeReplaced(iChangeCount) = oControl1.BackColor"
.insertlines iLine + 22, " ElseIf oControl1.Name = ""FieldLabel"" & iChangeCount & ""a"" Then"
.insertlines iLine + 23, " aReplacements(iChangeCount) = oControl1.BackColor"
.insertlines iLine + 24, " End If"
.insertlines iLine + 25, " End If"
.insertlines iLine + 26, " Next"
.insertlines iLine + 27, " End IF"
.insertlines iLine + 28, " End IF"
.insertlines iLine + 29, "Next"
.insertlines iLine + 30, " For i = 1 To UBound(aToBeReplaced)"
.insertlines iLine + 31, " For Each rCell In rWhole"
.insertlines iLine + 32, " If rCell.Interior.Color = aToBeReplaced(i) and rCell.Interior.ColorIndex <> xlNone Then rCell.Interior.Color = aReplacements(i)"
.insertlines iLine + 33, " Next"
.insertlines iLine + 34, " Next"
.insertlines iLine + 35, "End Sub"
End With
'----------------------------------- C L O S E ----------------------------------------------
'Add a Close button if the user wishes to exit the sub
Set NewButton = TempForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "Close"
.Caption = "Close"
.Top = (12 * (i + 2)) + 12
.Height = 20
.Left = 6 + 90 + 4 + 12 + 4 + 40
.Width = 50
End With
With TempForm.codemodule
iLine = .countoflines
.insertlines iLine + 1, "Sub Close_Click()"
'If the form is not found, then we don't need to do anything about deleting it
.insertlines iLine + 2, "On Error Resume Next"
.insertlines iLine + 3, "Unload Me"
.insertlines iLine + 4, " With ThisWorkbook.VBProject.VBComponents"
.insertlines iLine + 5, " .Remove .Item(""UserForm1"")"
.insertlines iLine + 6, " End With"
.insertlines iLine + 7, "End Sub"
End With
'-------------------------------- T I T L E S E T C ----------------------------------------------
Set NewLabel = TempForm.designer.Controls.Add("Forms.label.1")
With NewLabel
.Name = "OldColours"
.Caption = "Old"
.TextAlign = fmTextAlignCenter
.Top = 6
.Left = 6
.Width = 90
.Height = 12
.Font.Size = 9
.Font.Bold = True
.Font.Name = "Tahoma"
.BorderStyle = fmBorderStyleNone
End With
Set NewLabel = TempForm.designer.Controls.Add("Forms.label.1")
With NewLabel
.Name = "NewColours"
.Caption = "New"
.TextAlign = fmTextAlignCenter
.Top = 6
.Left = 6 + 90 + 4 + 12 + 4
.Width = 90
.Height = 12
.Font.Size = 9
.Font.Bold = True
.Font.Name = "Tahoma"
.BorderStyle = fmBorderStyleNone
End With
Set NewLabel = TempForm.designer.Controls.Add("Forms.label.1")
With NewLabel
.Name = "Instructions"
.Caption = "Click the New colour you wish to change. Only colours that are ticked will be replaced."
.TextAlign = fmTextAlignCenter
.Top = (12 * (i + 2)) + 12 + 20 + 6
.Left = 6
.Width = 90 + 4 + 12 + 4 + 90
.Height = 24
.Font.Size = 9
.Font.Name = "Arial"
.BorderStyle = fmBorderStyleNone
End With
TempForm.Properties("Height") = (12 * (i + 3)) + 76
'Show the form
VBA.UserForms.Add(TempForm.Name).Show
'Delete the form
ThisWorkbook.VBProject.VBComponents.Remove TempForm
ErrChecker:
If Err.Number <> 0 Then
If Err.Number = 9 Then
GoTo CarryOn1
Else: MsgBox "Error Returned"
Exit Sub
End If
End If
End Sub