Go to Qiita Advent Calendar 2024 Top
LoginSignup
4
5

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 5 years have passed since last update.

@sioaji

excelの表を Redmine Textile の表に変換

Last updated at Posted at 2019-03-13

今まで、こちらの記事を参考に、excelの表を Redmine Textile の表に変換していました。

・Excelの表をTextile形式のテーブルにしてみる
　https://qiita.com/acknpop/items/2c5e3aee4edfee197625

結果はこんな感じ。
before.png

生成されるコードが完結で、redmine側で表を更新していきたい場合は
修正しやすいので、主にこちらを使っています。

|B6|C6|D6|E6|F6|
|B7|/2\2=. *+_C6
-D8_+*|E7|F7|
|B8|E8|F8|
|*-+_B9_+-*|C9|D9|E9|F9|

しかし、ただエクセルの表を表示させたい場合、
セルや文字の色もそのまま載せたいので、スクリーンショットなどを貼り付けたりしていました。

今回は、セルや文字の色もTextileに変換する様にソースを修正しましたので掲載します。

こんな感じです。

元のエクセル画面

excel.PNG

変換前に問い合わせ追加

OptionMenu.PNG

結果

Result.PNG

Redmine表示

コードは大変みにくくなりますが・・・。

wiki.PNG

見た目は良いです。

wikiexcel.PNG

ソース

オプションメニューを追加

オプションのチェックボックスをクリックしたら、
全ON、OFFのチェックボックスを自動更新する為に、
オプションのチェックボックスをクラス化して記述を楽にしました。

Class1

Option Explicit

Private WithEvents Target As MSForms.CheckBox

' 詳細チェックボックスは、同じ処理をするのでクラスで共通化
Public Sub SetCtrl(new_ctrl As MSForms.CheckBox)
  Set Target = new_ctrl
End Sub

' 詳細チェックボックスクリックで共通処理
Private Sub Target_Click()

    UserForm1.UpdateCheckBox
    
End Sub

アドイン本体

Excel2RedmineWiki

Option Explicit

' OPTIONデータ
Public PosLeft As Boolean   ' 左寄せ
Public PosRight As Boolean  ' 右寄せ
Public PosCentor As Boolean ' センター
Public PosUpper As Boolean  ' 上寄せ
Public PosLower As Boolean  ' 下寄せ

Public DecoItalic As Boolean ' 斜体
Public DecoUline As Boolean  ' 下線
Public DecoLine As Boolean   ' 取消線
Public DecoBold As Boolean   ' 太字

Public ColorFont As Boolean   ' 文字色
Public ColorBack As Boolean   ' 背景色

Public strALL As String ' 変換した全データを作る変数

Public IniFilePath As String            ' INIファイルのパス取得用
Public DontShowOptionMenu As Boolean    ' オプションメニュー非表示判断用

'ハイパーリンクを取得
Private Function linkAddress(r As Range) As String
    If r.Hyperlinks.Count > 0 Then '指定したセルにハイパーリンクオブジェクトがある
        linkAddress = r.Hyperlinks(r.Hyperlinks.Count).Address
        If r.Hyperlinks(r.Hyperlinks.Count).SubAddress <> "" Then
            linkAddress = linkAddress & "#" & r.Hyperlinks(r.Hyperlinks.Count).SubAddress
        End If
    Else
        If InStr(r.Formula, "=HYPERLINK") Then 'HYPERLINK関数を使っている
            linkAddress = Mid(r.Formula, 13, InStr(13, r.Formula, """") - 13)
        Else
            linkAddress = ""
        End If
    End If
End Function

' 文字列前後の改行を削除
Private Function TrimLF(str As String) As String
  Dim strTmp As String
  strTmp = str
  Do Until Left(strTmp, 1) <> vbLf
    strTmp = Mid(strTmp, 2)
  Loop
  Do Until Right(strTmp, 1) <> vbLf
    strTmp = Left(strTmp, Len(strTmp) - 1)
  Loop
  TrimLF = strTmp
End Function

' 色変換を行う。
Private Function Excel2RedmineColor(excelColor As Long)
    ' excelColor = red + green*256 + blue*256*256
    ' htmlColor  = red*256*256 + green*256 + blue
    Dim blue, green, red As Long
    Dim num, buf As Long

    num = CLng(256) * 256

    blue = excelColor \ num     ' 商
    buf = excelColor Mod num    ' 余り
    green = buf \ 256
    red = buf Mod 256

    Excel2RedmineColor = (red * num) + (green * 256) + (blue)
End Function

'機能：指定文字埋め関数
'引数：str　：変換前の文字列
'　　　chr  ：埋める文字(１文字目のみ使用)
'　　　digit：桁数
'戻値：指定文字埋め後の文字列
'使用例: FormatDigit("1F", "0", 6)
Function FormatDigit(ByVal str As String, _
                     ByVal char As String, _
                     ByVal digit As Long) As String
  Dim tmp As String
  tmp = str
  If Len(str) < digit And Len(char) > 0 Then
    tmp = Right(String(digit, char) & str, digit)
  End If
  FormatDigit = tmp
End Function

' クリップボードに書き出す
Public Sub Excel2RedmineWiki()

    Dim strROW As String ' 変換した１行のデータを作る変数
    Dim i As Long

    Dim mTop As Range   ' 結合セル取得用
    Dim rSpan, cSpan As Long ' 結合セルの行数、列数

    Dim aStr As String  ' セル内配置の書式用
    Dim sStr As String  ' 結合セルの書式用
    Dim deco As String  ' 色
    Dim dStr As String  ' 文字列の装飾用
    Dim hl As String    ' ハイパーリンク

    ' 選択したセルを取得
    Dim cl As Range
    Set cl = Selection

    ' ばかよけ
    If cl.Count = 1 Then
        MsgBox "1つのセルには対応していません。" & vbCrLf & "複数のセルを選択してください。", vbExclamation
        Exit Sub
    End If
    
    ' INIファイルより、オプションメニューを表示するか判断
    IniFilePath = ThisWorkbook.Path & "\Excel2RedmineWiki.ini"
    DontShowOptionMenu = Readini(IniFilePath, "OPTION", "DontShowOptionMenu")
    If DontShowOptionMenu = False Then
        ' OPTIONフォームOKボタン確認
        Dim retOK As Boolean
        retOK = UserForm1.Retfnc
        If retOK = False Then
          Exit Sub ' Cancel
        End If
    End If

    ' 変換した全データを作る変数を初期化
    strALL = ""

    ' 今見ている行を記憶
    Dim rLast As Long
    rLast = 0

    For Each cl In Selection

        ' 表示されているセルのみ対象とする
        '  SelectionにSpecialCells(xlCellTypeVisible)を付けると
        '  取得されるセルの順番が縦優先になってしまうので使わない
        If cl.Rows.Hidden = False And cl.Columns.Hidden = False Then

            If rLast = 0 Then rLast = cl.Row ' 今見ている行を取得して記憶(初期化)
            ' 見ている行が変わったら"|"を付ける処理
            If cl.Row <> rLast Then
                strROW = strROW & "|"
                strALL = strALL & strROW & vbCrLf
                strROW = ""
                rLast = cl.Row ' 今見ている行を更新
            End If

            ' セルが結合されている場合、一番左上のセルの時だけ処理をする為の操作
            If cl.MergeCells Then
                ' 結合セルの基点が非表示の場合の処理
                '  結合セルを順番に取得して非表示じゃ無くなったら抜ける
                '  結果、mTopには、表示されている一番左上のセルが取得された状態で抜ける
                For i = 1 To cl.MergeArea.Count
                    Set mTop = cl.MergeArea.Item(i) ' セルを取得
                    If mTop.Rows.Hidden = False And mTop.Columns.Hidden = False Then
                        Exit For
                    End If
                Next i

                ' 結合セルの一番左上以外は、GoToでスキップ
                If cl.Address <> mTop.Address Then
                    GoTo Continue
                End If

            End If

            aStr = ""
            sStr = ""
            deco = ""
            
            With cl.MergeArea ' With内、.で始まる処理はcl.MergeAreaに対する処理

                ' 結合範囲の取得
                rSpan = .Rows.Count     ' 結合されていない場合は 1となる
                cSpan = .Columns.Count  ' 結合されていない場合は 1となる

                ' セルが結合されている場合
                If cl.MergeCells Then

                    ' 結合範囲内の非表示分を減算
                    For i = 1 To .Rows.Count - 1
                        If .Cells(i, 1).Rows.Hidden = True Then
                            rSpan = rSpan - 1
                        End If
                    Next i
                    For i = 1 To .Columns.Count - 1
                        If .Cells(1, i).Columns.Hidden = True Then
                            cSpan = cSpan - 1
                        End If
                    Next i

                    ' 結合セル数をTextile形式に
                    If rSpan > 1 Then sStr = "/" & rSpan        ' 行の結合
                    If cSpan > 1 Then sStr = sStr & "\" & cSpan ' 列の結合

                End If

                ' 配置情報を取得
                If .HorizontalAlignment = xlLeft And PosLeft Then aStr = "<"    ' 左寄せ
                If .HorizontalAlignment = xlRight And PosRight Then aStr = ">"   ' 右寄せ
                If .HorizontalAlignment = xlCenter And PosCentor Then aStr = "="  ' センター

                If .VerticalAlignment = xlVAlignTop And PosUpper Then aStr = aStr & "^" ' 上寄せ
                If .VerticalAlignment = xlVAlignBottom And PosLower And rSpan > 1 Then aStr = aStr & "~" ' 下寄せ

                ' 文字色,背景色
                If .Item(1).Font.Color <> 0 And ColorFont Then
                    deco = "color:#" & FormatDigit(Hex(Excel2RedmineColor(.Item(1).Font.Color)), "0", 6) & ";"
                End If
                If .Item(1).Interior.Color <> &HFFFFFF And ColorBack Then
                    deco = deco & "background:#" & FormatDigit(Hex(Excel2RedmineColor(.Item(1).Interior.Color)), "0", 6) & ";"
                End If
                If deco <> "" Then
                    deco = "{" & deco & "}"
                End If

                If .Item(1).Text = "" Then aStr = ""

                strROW = strROW & "|" & sStr & aStr & deco
                If sStr <> "" Or aStr <> "" Or deco <> "" Then strROW = strROW & ". "

                ' 空行を削除       :Replace(.Item(1).Text, vbLf & vbLf, vbLf)
                ' 前後の改行を削除  :TrimLF
                ' 前後の空白を削除  :Trim
                dStr = Trim(TrimLF(Replace(.Item(1).Text, vbLf & vbLf, vbLf)))

                ' ハイパーリンクの取得
                hl = linkAddress(.Item(1))

                ' ハイパーリンクがある場合
                If hl <> "" Then
                    strROW = strROW & """" & Replace(dStr, vbLf, vbCrLf) & """:" & hl
                Else
                    ' セル修飾対応
                    If dStr <> "" Then
                        ' 斜体
                        If .Item(1).Font.Italic And DecoItalic Then
                            dStr = "_" & dStr & "_"
                        End If
                        ' 下線
                        If .Item(1).Font.Underline <> xlUnderlineStyleNone And DecoUline Then
                            dStr = "+" & dStr & "+"
                        End If
                        ' 取消線
                        If .Item(1).Font.Strikethrough And DecoLine Then
                            dStr = "-" & dStr & "-"
                        End If
                        ' 太字 (太字は最後にしないと機能しない)
                        If .Item(1).Font.Bold And DecoBold Then
                            dStr = "*" & dStr & "*"
                        End If
                    End If

                    strROW = strROW & Replace(dStr, vbLf, vbCrLf)
                End If

            End With ' cl.MergeArea

        End If ' Not Hidden

Continue:
    Next ' Selection（次の列又は行へ）

    ' 最後の"|"を付ける処理
    If strROW <> "" Then
        strROW = strROW & "|"
        strALL = strALL & strROW & vbCrLf
    End If

    ' クリップボードへコピー
    Dim CB As New DataObject
    CB.Clear
    CB.SetText strALL
    CB.PutInClipboard
    Set CB = Nothing
    
    UserForm2.Show

'    MsgBox "クリップボードにコピーしました。" & vbCrLf & vbCrLf & strALL

End Sub

INIフィアルを読み書きする為の標準的なモジュール

こちらは、google先生よりソースを入手しました。

Tools

Option Explicit

Private Declare Function GetPrivateProfileString Lib "kernel32" _
                         Alias "GetPrivateProfileStringA" _
                         (ByVal lpApplicationName As String, _
                          ByVal lpKeyName As Any, _
                          ByVal lpDefault As String, _
                          ByVal lpReturnedString As String, _
                          ByVal nSize As Long, _
                          ByVal lpFileName As String) As Long
                          
Private Declare Function WritePrivateProfileString Lib "kernel32" _
                         Alias "WritePrivateProfileStringA" _
                         (ByVal lpApplicationName As String, _
                          ByVal lpKeyName As Any, _
                          ByVal lpString As Any, _
                          ByVal lpFileName As String) As Long

Private Const STRING_MAX_SIZE As Integer = 4096

'  【入出力】 striniFile      ： (I)  iniファイル名（ファイル名はフルパスとする事）
'             strSection      ： (I)  iniファイルセクション名
'             strKey          ： (I)  iniファイルキー名
'  【戻り値】 読み込んだiniファイルのvalue値。
Public Function Readini(ByVal striniFile As String, _
                        ByVal strSection As String, _
                        ByVal strKey As String) As String

  Dim nret As Long    '復帰値格納用
  '---------------
  ' iniファイル読み込み時の設定文字（固定長）
  ' STRING_MAX_SIZE分の固定領域
  ' iniファイル読み込み時、可変長ではアボートする。
  '---------------
  Dim strValue As String * STRING_MAX_SIZE

   strValue = Space(STRING_MAX_SIZE) 'スペース埋めしておかないとサイズ指定の文字列はゴミが入っている。(初期化されていない。)
   nret = GetPrivateProfileString(strSection, strKey, "", strValue, STRING_MAX_SIZE, striniFile)

  'iniファイル読み込みで取得した文字列はNULLも取ってしまっているので、NULLの直前まで取得
  Readini = Left(strValue, (InStr(strValue, Chr(0)) - 1))
End Function

'  【入出力】 striniFile      ： (I)  iniファイル名
'             strSection      ： (I)  iniファイルセクション名
'             strKey          ： (I)  iniファイルキー名
'             strValue        ： (I)  iniファイルに書き込む値。VALUE値。
'
'  【戻り値】 書き込み結果
Public Function Writeini(ByVal striniFile, ByVal strSection As String, ByVal strKey As String, ByVal strValue As String) As Long
    Dim lret As Long
    lret = WritePrivateProfileString(strSection, strKey, strValue, striniFile)
    Writeini = lret
End Function

INIファイル本体

Excel2RedmineWiki.ini

[POSITION]
PosLeft=True
PosRight=True
PosCentor=True
PosUpper=True
PosLower=True

[DECO]
DecoItalic=True
DecoUline=True
DecoLine=True
DecoBold=True

[COLOR]
ColorFont=True
ColorBack=True

[OPTION]
DontShowOptionMenu=False

オプションメニューのユーザーフォーム

UserForm1

Option Explicit

Dim userForm1OK As Boolean

' 同じ処理をするチェックボックスは、クラスで共通化
Private ctrlPos(1 To 5) As New Class1
Private ctrlDeco(8 To 11) As New Class1
Private ctrlColor(13 To 14) As New Class1

' OPTIONメニュー次回表示しない
Private Sub CheckBox16_Click()

End Sub

' 全ON (配置)
Private Sub CheckBox6_Click()
    Dim i As Integer
    
    If Me.CheckBox6.Value = True Then
        For i = LBound(ctrlPos) To UBound(ctrlPos)
          Me("CheckBox" & i) = True
        Next
    End If
    
End Sub

' 全OFF (配置)
Private Sub CheckBox17_Click()
    Dim i As Integer
    
    If Me.CheckBox17.Value = True Then
        For i = LBound(ctrlPos) To UBound(ctrlPos)
          Me("CheckBox" & i) = False
        Next
    End If

End Sub

' 全ON (装飾)
Private Sub CheckBox7_Click()
    Dim i As Integer
    
    If Me.CheckBox7.Value = True Then
        For i = LBound(ctrlDeco) To UBound(ctrlDeco)
          Me("CheckBox" & i) = True
        Next
    End If
    
End Sub

' 全OFF (装飾)
Private Sub CheckBox18_Click()
    Dim i As Integer
    
    If Me.CheckBox18.Value = True Then
        For i = LBound(ctrlDeco) To UBound(ctrlDeco)
          Me("CheckBox" & i) = False
        Next
    End If
    
End Sub

' 全ON (色)
Private Sub CheckBox12_Click()
    Dim i As Integer
    
    If Me.CheckBox12.Value = True Then
        For i = LBound(ctrlColor) To UBound(ctrlColor)
          Me("CheckBox" & i) = True
        Next
    End If
    
End Sub

' 全OFF (色)
Private Sub CheckBox19_Click()
    Dim i As Integer
    
    If Me.CheckBox19.Value = True Then
        For i = LBound(ctrlColor) To UBound(ctrlColor)
          Me("CheckBox" & i) = False
        Next
    End If

End Sub

' 全ON
Private Sub CheckBox15_Click()
    If Me.CheckBox15.Value = True Then
        Me.CheckBox6.Value = True  ' 全ON (配置)
        Me.CheckBox7.Value = True  ' 全ON (装飾)
        Me.CheckBox12.Value = True  ' 全ON (色)
        
    End If
End Sub

' 全OFF
Private Sub CheckBox20_Click()
    If Me.CheckBox20.Value = True Then
        Me.CheckBox17.Value = True  ' 全OFF (配置)
        Me.CheckBox18.Value = True  ' 全OFF (装飾)
        Me.CheckBox19.Value = True  ' 全OFF (色)
        
    End If
End Sub

' 初期化
Private Sub UserForm_Initialize()
    Dim i As Integer
    For i = LBound(ctrlPos) To UBound(ctrlPos)
      ctrlPos(i).SetCtrl Me("CheckBox" & i)
    Next

    For i = LBound(ctrlDeco) To UBound(ctrlDeco)
        ctrlDeco(i).SetCtrl Me("CheckBox" & i)
    Next

    For i = LBound(ctrlColor) To UBound(ctrlColor)
        ctrlColor(i).SetCtrl Me("CheckBox" & i)
    Next
End Sub

' ユーザーフォーム起動関数
Public Function Retfnc() As Boolean
    ' INIファイルより
    PosLeft = Readini(IniFilePath, "POSITION", "PosLeft")
    PosRight = Readini(IniFilePath, "POSITION", "PosRight")
    PosCentor = Readini(IniFilePath, "POSITION", "PosCentor")
    PosUpper = Readini(IniFilePath, "POSITION", "PosUpper")
    PosLower = Readini(IniFilePath, "POSITION", "PosLower")
    
    DecoItalic = Readini(IniFilePath, "DECO", "DecoItalic")
    DecoUline = Readini(IniFilePath, "DECO", "DecoUline")
    DecoLine = Readini(IniFilePath, "DECO", "DecoLine")
    DecoBold = Readini(IniFilePath, "DECO", "DecoBold")
    
    ColorFont = Readini(IniFilePath, "COLOR", "ColorFont")
    ColorBack = Readini(IniFilePath, "COLOR", "ColorBack")
    
    DontShowOptionMenu = Readini(IniFilePath, "OPTION", "DontShowOptionMenu")
    
    Me.CheckBox1.Value = PosLeft    ' 左寄せ
    Me.CheckBox2.Value = PosRight   ' 右寄せ
    Me.CheckBox3.Value = PosCentor  ' センター
    Me.CheckBox4.Value = PosUpper   ' 上寄せ
    Me.CheckBox5.Value = PosLower   ' 下寄せ
    
    Me.CheckBox8.Value = DecoItalic ' 斜体
    Me.CheckBox9.Value = DecoUline  ' 下線
    Me.CheckBox10.Value = DecoLine  ' 取消線
    Me.CheckBox11.Value = DecoBold  ' 太字
    
    Me.CheckBox13.Value = ColorFont  ' 文字色
    Me.CheckBox14.Value = ColorBack  ' 背景色
    
    Me.CheckBox16.Value = DontShowOptionMenu  ' 次回表示しない
    
    ' 全ON情報更新
    UpdateCheckBox
    
    ' ユーザーフォーム表示
    Me.Show
    
    Retfnc = userForm1OK  ' Booleanの場合は、Unload後も、まだ値を維持。
End Function
    
' OK
Private Sub OkButton_Click()
    Dim lret As Long

    userForm1OK = True
    
    PosLeft = Me.CheckBox1.Value    ' 左寄せ
    PosRight = Me.CheckBox2.Value   ' 右寄せ
    PosCentor = Me.CheckBox3.Value  ' センター
    PosUpper = Me.CheckBox4.Value   ' 上寄せ
    PosLower = Me.CheckBox5.Value   ' 下寄せ
    
    DecoItalic = Me.CheckBox8.Value ' 斜体
    DecoUline = Me.CheckBox9.Value  ' 下線
    DecoLine = Me.CheckBox10.Value  ' 取消線
    DecoBold = Me.CheckBox11.Value  ' 太字
    
    ColorFont = Me.CheckBox13.Value  ' 文字色
    ColorBack = Me.CheckBox14.Value  ' 背景色
    
    DontShowOptionMenu = Me.CheckBox16.Value  ' 次回表示しない
    
    ' INIファイル更新(書込み成功したかどうかはチェックしない)
    lret = Writeini(IniFilePath, "POSITION", "PosLeft", PosLeft)
    lret = Writeini(IniFilePath, "POSITION", "PosRight", PosRight)
    lret = Writeini(IniFilePath, "POSITION", "PosCentor", PosCentor)
    lret = Writeini(IniFilePath, "POSITION", "PosUpper", PosUpper)
    lret = Writeini(IniFilePath, "POSITION", "PosLower", PosLower)
    
    lret = Writeini(IniFilePath, "DECO", "DecoItalic", DecoItalic)
    lret = Writeini(IniFilePath, "DECO", "DecoUline", DecoUline)
    lret = Writeini(IniFilePath, "DECO", "DecoLine", DecoLine)
    lret = Writeini(IniFilePath, "DECO", "DecoBold", DecoBold)
    
    lret = Writeini(IniFilePath, "COLOR", "ColorFont", ColorFont)
    lret = Writeini(IniFilePath, "COLOR", "ColorBack", ColorBack)
    
    lret = Writeini(IniFilePath, "OPTION", "DontShowOptionMenu", DontShowOptionMenu)
    
    Unload Me
    ' フォームを閉じるとき、自分を表示したRetfnc関数の 「Me.Show」の次の行に飛ぶ
    ' フォーム側で確保した変数はUnload以降アクセスできない（Booleanは例外らしい）
    ' ので、グローバル変数に保存する必要がある。
End Sub

' Cancel
Private Sub CancelButton_Click()
    userForm1OK = False
    Unload Me
End Sub

' 配置チェックボックスの更新
Private Sub UpdateCheckBoxPos()

   ' 左寄せ ' 右寄せ ' センター ' 上寄せ ' 下寄せ
    If Me.CheckBox1.Value = True And _
       Me.CheckBox2.Value = True And _
       Me.CheckBox3.Value = True And _
       Me.CheckBox4.Value = True And _
       Me.CheckBox5.Value = True Then
       
       Me.CheckBox6.Value = True  ' 全ON
    
    Else
       Me.CheckBox6.Value = False
    End If

    If Me.CheckBox1.Value = False And _
       Me.CheckBox2.Value = False And _
       Me.CheckBox3.Value = False And _
       Me.CheckBox4.Value = False And _
       Me.CheckBox5.Value = False Then
       
       Me.CheckBox17.Value = True  ' 全OFF
    
    Else
       Me.CheckBox17.Value = False
    End If

End Sub

' 装飾チェックボックスの更新
Private Sub UpdateCheckBoxDeco()
    
    ' 斜体 ' 下線 ' 取消線 ' 太字
    If Me.CheckBox8.Value = True And _
       Me.CheckBox9.Value = True And _
       Me.CheckBox10.Value = True And _
       Me.CheckBox11.Value = True Then
       
       Me.CheckBox7.Value = True  ' 全ON
       
    Else
       Me.CheckBox7.Value = False
    End If
    
    If Me.CheckBox8.Value = False And _
       Me.CheckBox9.Value = False And _
       Me.CheckBox10.Value = False And _
       Me.CheckBox11.Value = False Then
       
       Me.CheckBox18.Value = True  ' 全OFF
       
    Else
       Me.CheckBox18.Value = False
    End If
    
End Sub

' 色チェックボックスの更新
Private Sub UpdateCheckBoxColor()

    ' 文字色 ' 背景色
    If Me.CheckBox13.Value = True And _
       Me.CheckBox14.Value = True Then
       
       Me.CheckBox12.Value = True  ' 全ON
       
    Else
       Me.CheckBox12.Value = False
    End If
    
    If Me.CheckBox13.Value = False And _
       Me.CheckBox14.Value = False Then
       
       Me.CheckBox19.Value = True  ' 全OFF
       
    Else
       Me.CheckBox19.Value = False
    End If
    
End Sub

' 全チェックボックスの更新
Private Sub UpdateCheckBoxAll()
    
    If Me.CheckBox6.Value = True And _
       Me.CheckBox7.Value = True And _
       Me.CheckBox12.Value = True Then
       
       Me.CheckBox15.Value = True  ' 全ON
       
    Else
       Me.CheckBox15.Value = False
    End If
    
    If Me.CheckBox17.Value = True And _
       Me.CheckBox18.Value = True And _
       Me.CheckBox19.Value = True Then
       
       Me.CheckBox20.Value = True  ' 全OFF
       
    Else
       Me.CheckBox20.Value = False
    End If
    
End Sub

' 全てを更新する
Public Sub UpdateCheckBox()
    UpdateCheckBoxPos
    UpdateCheckBoxDeco
    UpdateCheckBoxColor
    UpdateCheckBoxAll
End Sub

変換結果を表示するユーザーフォーム

UserForm2

Option Explicit

' 初期化
Private Sub UserForm_Initialize()
    Me.TextBox1.Value = strALL  ' クリップボードにコピーしたデータ
    
    If DontShowOptionMenu = True Then  ' 次回表示しない
        Me.CheckBox1.Value = False
    Else
        Me.CheckBox1.Value = True ' 次回オプションメニューを表示する
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim lret As Long
    
    lret = Writeini(IniFilePath, "OPTION", "DontShowOptionMenu", DontShowOptionMenu)

    Unload Me
End Sub

Private Sub CheckBox1_Click()
    If Me.CheckBox1.Value = True Then ' 次回オプションメニューを表示する
        DontShowOptionMenu = False
    Else
        DontShowOptionMenu = True ' 次回表示しない
    End If
End Sub

Private Sub UserForm_Click()

End Sub

エクセルのリボンとかツールバーにマクロを表示する

google先生、よろしくお願いします。

こちらなど。。。
https://hamachan.info/win7/Excel/macro.html
マクロをリボンに登録するには

4
5
2

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
4
5

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?