www.smiyasaka.com  は、2019 年2月から SSL 化し 通信を暗号化した方式で発信をしています。

● セル・フォントの色コード一覧表の作成マクロ  ●


'---------------------------------------------------------------
'  セル・フォントの色コード一覧表の作成マクロ
'  図形の線・塗りつぶしの色コード一覧表の作成マクロ
'  このまま、コピペして使用できます。
'  1. カラーインデックスコードと色( 色コード一覧表 )
'  2. セルの色削除
'  3. RGBコードでセルの色付け
'   1項で作成した表を一度セルの色だけ削除した表のRGBコードを
'   使用してセルに色けします。
'  4. 全ての図線を削除
'  5. 直線_カラーインデックスコードで色付け( 色コード一覧表 )
'  6. 直線_RGBコードで色付け
'   5項で作成した表を一度線だけ削除した表のRGBコードを
'   使用して色付きの直線を描きます。
'---------------------------------------------------------------

Sub カラーインデックスコードと色()
  Dim i, r, x As Single
  Dim HEX_code, R_code, G_code, B_code As String
  x = -5
  r = 1
  For i = 1 To 56
    If r = 1 Or r = 22 Then
    x = x + 5: r = 1
    Cells(r, x + 1) = "ColorIndex No"
    yy = r: xx = x + 1: 折返し中央表示 xx, yy
    Cells(r, x + 2) = "Indexコードで塗潰し"
    yy = r: xx = x + 2: 折返し中央表示 xx, yy
    Cells(r, x + 3) = "10進コード"
    yy = r: xx = x + 3: 折返し中央表示 xx, yy
    Cells(r, x + 4) = "RGB コード"
    yy = r: xx = x + 4: 折返し中央表示 xx, yy
    r = 2
    End If
  '
    Cells(r, x + 1) = i
    yy = r: xx = x + 1: 中央表示 xx, yy
    Cells(r, x + 2).Interior.ColorIndex = i
    Cells(r, x + 3) = Cells(r, x + 2).Interior.Color ' 背景色取得
    '
    ' 10進コードを一度16進コードに変換し、R,G,B 毎 10進コードに変換する。
    '
    HEX_code = Right("000000" & Hex(Cells(r, x + 2).Interior.Color), 6)
    '
    R_code = Right("  " & CStr(CDec("&H" & Right(HEX_code, 2))), 3) 
    G_code = Right("  " & CStr(CDec("&H" & Mid(HEX_code, 3, 2))), 3)
    B_code = Right("  " & CStr(CDec("&H" & Left(HEX_code, 2))), 3)
    '
    Cells(r, x + 4).Select
    Selection.NumberFormatLocal = "@"  ' セルの書式を文字列にする
    ' コードによっては、3桁毎の , になり数値になるので強制的に
    ' 文字列にする。
    Cells(r, x + 4) = R_code & "," & G_code & "," & B_code
       
    yy = r: xx = x + 4: 中央表示 xx, yy
  '
    Cells(r, x + 1).Select
    With Selection.Font
      .Name = "Century Gothic" ' 文字をCentury Gothicにする
      .Bold = True       ' 太字にする
    End With
  '
     r = r + 1
  Next

  セルサイズ編集
  ' 枠線引く
  Range("A1:N21").Borders.LineStyle = True
  '
End Sub
'---------------------------------------------------------------
Sub 折返し中央表示(xx, yy As Variant)
  Cells(yy, xx).Select
  With Selection
    .HorizontalAlignment = xlCenter ' 中央表示
    .WrapText = True        ' 折返し表示
  End With
End Sub
'---------------------------------------------------------------
Sub 中央表示(xx, yy As Variant)
  Cells(yy, xx).Select
  With Selection
    .HorizontalAlignment = xlCenter ' 中央表示
  End With
End Sub
'---------------------------------------------------------------
Sub セルサイズ編集()
'
  Rows("1:1").RowHeight = 27.75
  Columns("A:A").ColumnWidth = 9.25
  Columns("F:F").ColumnWidth = 9.25
  Columns("K:K").ColumnWidth = 9.25
  
  Columns("E:E").ColumnWidth = 1
  Columns("J:J").ColumnWidth = 1
  
  Columns("B:B").ColumnWidth = 9.75
  Columns("G:G").ColumnWidth = 9.75
  Columns("L:L").ColumnWidth = 9.75
  
  Columns("C:C").ColumnWidth = 8.75
  Columns("H:H").ColumnWidth = 8.75
  Columns("M:M").ColumnWidth = 8.75
  
  Columns("D:D").ColumnWidth = 11
  Columns("I:I").ColumnWidth = 11
  Columns("N:N").ColumnWidth = 11
  
End Sub
'---------------------------------------------------------------
Sub セルの色削除()
  Range("A1:N21").Select
  Selection.Interior.Pattern = xlNone
  Range("A1").Select
End Sub
'---------------------------------------------------------------
Sub RGBコードでセルの色付け()
  '
  ' RGB色コードの検証
  '
  Dim i, r, x As Single
  Dim R_code, G_code, B_code As Long
  x = -5
  r = 1
  For i = 1 To 56
    If r = 1 Or r = 22 Then
    x = x + 5: r = 2
    End If
  ' RGB コードの文字列から、赤・緑・青の文字列データを抜出し、
  ' 数値に変換する
    R_code = Val(Mid(Cells(r, x + 4).Value, 1, 3))  ' 赤
    G_code = Val(Mid(Cells(r, x + 4).Value, 5, 3))  ' 緑
    B_code = Val(Right(Cells(r, x + 4).Value, 3))   ' 青
        
    Cells(r, x + 2).Interior.Color = _
                        RGB(R_code, G_code, B_code)   ' セルの色付け
    '
     r = r + 1
  Next
  
End Sub
'
'---------------------------------------------------------------
'      ここからは、図形の色コード
'---------------------------------------------------------------
'
Sub 全ての図線を削除()
  ' 全ての図・線を削除する。
  ActiveSheet.Shapes.SelectAll
  Selection.Delete
  
End Sub
'---------------------------------------------------------------
Sub 直線_カラーインデックスコードで色付け()
  Dim i, r, x As Single
  Dim HEX_code, Line_name As String
  Dim x1, x2, y1, y2 As Long
  x = -5
  r = 1
  For i = 1 To 56
    If r = 1 Or r = 22 Then
    x = x + 5: r = 1
    Cells(r, x + 1) = "ColorIndex No"
    yy = r: xx = x + 1: 折返し中央表示 xx, yy
    Cells(r, x + 2) = "Indexコードで色付け"
    yy = r: xx = x + 2: 折返し中央表示 xx, yy
    Cells(r, x + 3) = "10進コード"
    yy = r: xx = x + 3: 折返し中央表示 xx, yy
    Cells(r, x + 4) = "RGBコード"
    yy = r: xx = x + 4: 折返し中央表示 xx, yy
    r = 2
    End If
'
    Cells(r, x + 1) = i
    yy = r: xx = x + 1: 中央表示 xx, yy
    Cells(r, x + 2).Select
    ' -------- 直線線引き ------------
    '
    With Selection   ' 選択したセルの座標位置・サイズを取得する
      x1 = .Left   ' 横位置
      y1 = .Top  ' 縦位置
      x2 = .Width  ' セルの幅
      y2 = .Height ' セルの高さ
    End With
    ' 選択したセルの中央に線を引く  +2, -2 は、線が罫線に
    ' かからない様にする為
    ActiveSheet.Shapes.AddLine(x1 + 2, y1 + y2 / 2, x1 + x2 - 2, _
                                                     y1 + y2 / 2).Select
  
   Selection.ShapeRange.Line.Weight = 3             ' 線の太さ
   Selection.ShapeRange.Line.ForeColor.SchemeColor = _
                                        i    ' 線の色 ColorIndex 番号
   Selection.ShapeRange.Line.BeginArrowheadStyle = _
                                        msoArrowheadNone  ' 線の端 矢印なし
   Selection.ShapeRange.Line.EndArrowheadStyle = _
                                        msoArrowheadNone  ' 線の端 矢印なし
   Line_name = Selection.Name     ' 線の描画名を取得する
    ' ---------------------------------
    Cells(r, x + 3) = _
             ActiveSheet.Shapes(Line_name).Line.ForeColor  ' 線の色取得
    '
    ' 10進コードを一度16進コードに変換し、R,G,B 毎 10進コードに変換する。
    '
    HEX_code = Right("000000" & Hex(Cells(r, x + 3).Value), 6)
    '
    R_code = Right("  " & CStr(CDec("&H" & Right(HEX_code, 2))), 3)
    G_code = Right("  " & CStr(CDec("&H" & Mid(HEX_code, 3, 2))), 3)
    B_code = Right("  " & CStr(CDec("&H" & Left(HEX_code, 2))), 3)
    '
    Cells(r, x + 4).Select
    Selection.NumberFormatLocal = "@"   ' セルの書式を文字列にする
    ' コードによっては、3桁毎の , になり数値になるので強制的に
    ' 文字列にする。
    Cells(r, x + 4) = R_code & "," & G_code & "," & B_code
     
    yy = r: xx = x + 4: 中央表示 xx, yy
'
    Cells(r, x + 1).Select
    With Selection.Font
      .Name = "Century Gothic" ' 文字をCentury Gothicにする
      .Bold = True       ' 太字にする
    End With
 '
     r = r + 1
  Next

   セルサイズ編集
  ' 枠線引く
  Range("A1:N21").Borders.LineStyle = True

End Sub
'---------------------------------------------------------------
Sub 直線_RGBコードで色付け()
'---------------------------------------------------------------
'      RGBコードの検証
'---------------------------------------------------------------
  Dim i, r, x As Single
  Dim RGB_color As Variant
  Dim Line_name As String
  Dim x1, x2, y1, y2, R_code, G_code, B_code As Long
  x = -5
  r = 1
  For i = 1 To 56
    If r = 1 Or r = 22 Then
    x = x + 5: r = 2
    End If
  '
    Cells(r, x + 2).Select
    ' -------- 直線線引き ------------
    '
    With Selection   ' 選択したセルの座標位置・サイズを取得する
      x1 = .Left   ' 横位置
      y1 = .Top  ' 縦位置
      x2 = .Width  ' セルの幅
      y2 = .Height ' セルの高さ
    End With
    ' 選択したセルの中央に線を引く
    ActiveSheet.Shapes.AddLine(x1, y1 + y2 / 2, x1 + x2, _
                                              y1 + y2 / 2).Select
    '
    Selection.ShapeRange.Line.Weight = 2            ' 線の太さ
    ' RGB コードの文字列から、赤・緑・青の文字列データを
    ' 抜出し、数値に変換する
    R_code = Val(Mid(Cells(r, x + 4).Value, 1, 3))  ' 赤
    G_code = Val(Mid(Cells(r, x + 4).Value, 5, 3))  ' 緑
    B_code = Val(Right(Cells(r, x + 4).Value, 3))   ' 青
    ' RGBコードで線に色付け
   Selection.ShapeRange.Line.ForeColor.RGB = _
                             RGB(R_code, G_code, B_code)   ' 線の色
   Selection.ShapeRange.Line.BeginArrowheadStyle = _
                             msoArrowheadNone  ' 線の端 矢印なし
   Selection.ShapeRange.Line.EndArrowheadStyle = _
                             msoArrowheadNone  ' 線の端 矢印なし
    ' ---------------------------------
    '
     r = r + 1
  Next
  セルサイズ編集

End Sub


TOPへ戻る