EXCEL VBA Color Barのあるシートを一気に作るマクロ

Option Explicit
Public Type iColorRGB
Red As Double
Blu As Double
Gre As Double
End Type

Public Const Max_ColorValue = 16777215
Public Const BLUE_OFFSET = 65536
Public Const GREEN_OFFSET = 256
Public Const RED_OFFSET = 1
Public Const ColVbBl = 16711680
Public Const ColVbR = 255
Public Const ColVBW = 16777215
Public Const ColVBB = 0
Public Const ColVBM = 16711935
Public Const ColVBC = 16776960
Public Const ColVBG = 65280
Public Const ColVBY = 65535
Public Const BarToColor = 599.2405
Sub MakeScrolbar()
Const PosLt = 10.25, PosTp = 100.25, PosWh = 255.5, PosHt = 15.25
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
Dim SclBarR As ScrollBar
Dim SclBarB As ScrollBar
Dim SclBarG As ScrollBar
Dim SclBarLarge As ScrollBar
Dim v As Variant
On Error Resume Next
ws.UsedRange.Clear
ws.Shapes.SelectAll
Selection.Delete
On Error GoTo 0
With ws
.Range("H5").Value = "Decimal"
.Range("I5").Value = "Hex"
.Range("I6").Formula = "=""&H""&DEC2HEX(H6,2)"
.Range("I8").Formula = "=""&H""&DEC2HEX(H8,2)"
.Range("I10").Formula = "=""&H""&DEC2HEX(H10,2)"
.Range("H11").Formula = "=H6*" & RED_OFFSET & "+ H8*" & GREEN_OFFSET & "+H10*" & BLUE_OFFSET: Rem Reffernce http://www.ozgrid.com/forum/showthread.php?t=49072
.Range("H11").ShrinkToFit = True
.Range("G6").Value = "RED"
.Range("G8").Value = "Green"
.Range("G10").Value = "BLUE"
.Range("J6:K10").Merge
.Range("A13:I13").Merge
.Range("A15").Value = "Decimal"
.Range("A16").Value = "Hex"
.Range("B14").Value = "Total"
.Range("C14").Value = "Red"
.Range("D14").Value = "Green"
.Range("E14").Value = "Blue"
.Range("F14").Value = "Colorname"
.Range("B15").Formula = "=INT(A20*" & BarToColor & ")"
.Range("B15").ShrinkToFit = True
.Range("B16").Formula = "=""&H""&DEC2HEX(B15,6)"
.Range("B16").ShrinkToFit = True
.Range("C16").Formula = "=""&H""&DEC2HEX(C15,2)"
.Range("D16").Formula = "=""&H""&DEC2HEX(D15,2)"
.Range("E16").Formula = "=""&H""&DEC2HEX(E15,2)"
End With
ws.ScrollBars.Add(PosLt, PosTp, PosWh, PosHt).Select
With Selection
.LinkedCell = ws.Name & "!" & ws.Range("H6").Address(True, True)
.Min = 0
.Max = 255
.SmallChange = 1
.Name = "Scroll_Bar_Red"
.OnAction = "Scroll_Bar_Red_Change"
End With
ws.ScrollBars.Add(PosLt, PosTp + PosHt * 2 + 2, PosWh, PosHt).Select
With Selection
.LinkedCell = ws.Name & "!" & ws.Range("H8").Address(True, True)
.Min = 0
.Max = 255
.SmallChange = 1
.Name = "Scroll_Bar_Green"
.OnAction = "Scroll_Bar_Green_Change"
End With
ws.ScrollBars.Add(PosLt, PosTp + PosHt * 4.5 + 6, PosWh, PosHt).Select
With Selection
.LinkedCell = ws.Name & "!" & ws.Range("H10").Address(True, True)
.Min = 0
.Max = 255
.SmallChange = 1
.Name = "Scroll_Bar_Blue"
.OnAction = "Scroll_Bar_Blue_Change"
End With
 ws.ScrollBars.Add(0.75, 321.75, 483, 19.5).Select
With Selection
.LinkedCell = ws.Name & "!" & ws.Range("A20").Address(True, True)
.Min = 0
.Max = 30000
.SmallChange = 50
.Name = "Scroll_Bar_Large"
.OnAction = "Scroll_Bar_Blue_Large_Change"
End With
ws.Range("B20").Select
Rem reffernce
'http://stackoverflow.com/questions/10914136/is-there-a-way-using-vba-to-create-a-scroll-bar-and-button-with-links-to-each-a
End Sub
Sub Scroll_Bar_Red_Change()
Dim iRgb As iColorRGB
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
With ws
iRgb.Red = .Range("H6").Value
iRgb.Gre = .Range("H8").Value
iRgb.Blu = .Range("H10").Value
.Range("J6").Select
Selection.Interior.Color = RGB(iRgb.Red, iRgb.Gre, iRgb.Blu)
End With
End Sub
Sub Scroll_Bar_Blue_Change()
Dim iRgb As iColorRGB
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
With ws
iRgb.Red = .Range("H6").Value
iRgb.Gre = .Range("H8").Value
iRgb.Blu = .Range("H10").Value
.Range("J6").Select
Selection.Interior.Color = RGB(iRgb.Red, iRgb.Gre, iRgb.Blu)
End With
End Sub
Sub Scroll_Bar_Green_Change()
Dim iRgb As iColorRGB
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
With ws
iRgb.Red = .Range("H6").Value
iRgb.Gre = .Range("H8").Value
iRgb.Blu = .Range("H10").Value
.Range("J6").Select
Selection.Interior.Color = RGB(iRgb.Red, iRgb.Gre, iRgb.Blu)
End With
End Sub

Sub Scroll_Bar_Blue_Large_Change()
Const StLine = 165
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = ActiveSheet
Dim objCol As Collection
Dim iRgb As iColorRGB
Set objCol = rgbarray(ws.Range("B15").Value)
 ws.Range("C15").Value = objCol.Item(1): iRgb.Red = objCol.Item(1):
 ws.Range("D15").Value = objCol.Item(2): iRgb.Gre = objCol.Item(2)
ws.Range("E15").Value = objCol.Item(3): iRgb.Blu = objCol.Item(3)
 ws.Range("F15").Value = objCol.Item(4)
ws.Range("A13").Select
Selection.Interior.Color = RGB(iRgb.Red, iRgb.Gre, iRgb.Blu)

End Sub
Function rgbarray(colorvalue) As Collection
' この関数は、ユーザーによる入力内容を配列に挿入し、
' 配列を返します。
'Refference https://msdn.microsoft.com/ja-jp/library/cc376074.aspx
'Reffernce http://www.officetanaka.net/excel/vba/tips/tips146.htm
Dim astrItems As New Collection
Dim iRgb As iColorRGB
Dim Blue2Green As Long
Dim ar, br, i As Long
Dim strColorString As String
ar = Array(ColVBB, ColVBW, ColVbBl, ColVBM, ColVbR, ColVBY, ColVBG, ColVBC)
br = Array("Black", "White", "Blue", "Magenta", "Red", "Yellow", "Green", "Cyan")
If colorvalue > Max_ColorValue Then colorvalue = Max_ColorValue
For i = LBound(ar) To UBound(ar)
If ar(i) = colorvalue Then strColorString = br(i): Exit For
Next i
'Caluculate RGB Color Number
iRgb.Blu = Fix(colorvalue / BLUE_OFFSET)
Blue2Green = colorvalue - (iRgb.Blu * BLUE_OFFSET)
iRgb.Gre = Fix(Blue2Green _
/ GREEN_OFFSET)
iRgb.Red = Blue2Green - (iRgb.Gre * 256)
'End:Caluculate RGB Color Number
astrItems.Add (iRgb.Red)
astrItems.Add (iRgb.Blu)
astrItems.Add (iRgb.Gre)
astrItems.Add (strColorString)
Set rgbarray = astrItems
If Not astrItems Is Nothing Then Set astrItems = Nothing
End Function

ポイント

色の変換 Type とColleciton

Typeで三色を入れられるようにしておく
UserFunctionは色のRGBと色の名前を返す
このため配列ではなくコレクションを使う。

定数の活用

なぜかわかりませんが、255*255などとするとエラーが出てしまいます。
なので、定数で定義します。
色の名前も理論的には増やせますが、VBで定まっている基本色を定義しました。
でかいスクロールバーの方は、8色のどれかにあたると名前が表示されます。
普通はシロと黒しか出せません。

スクロールバーで気が付いたこと

例えばワークシートだと
Set ws =Wb.add
とできますが、この方法は使う方法がわかりませんでした。
そこで、スタックにあった方法で
Addと同時にプロパティを叩き込みます。
名前も定義できないみたいですが、無理やり定義します。
ついでにコードも定義します。

関数 rgbarray

本当はコレクションが正しいのですが、もうこの名前で作ったので当面このままです。
この関数はConstとともに使用しますので、ほかに使う場合は定数もコピーしてください。
Publicのため標準モジュールの１つに定義すればすべてのモジュールで使えます。