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へ戻る