G-Tool2-Main-B00_WS比較用

Excel VBA
2023.10.16

ワークシートの比較ツール

Mainの【ワークシート比較ツール.xlsm】と、結果を書き込む【ワークシート比較結果雛形.xlsm】の
２つのブックを作成します。（Microsoft365 64bit環境推奨）

実行ブックの作成（再掲）

  1. 新規ブックを作成します。
  2. 最初に、【ページレイアウト】タブをクリック
  3. まず、左上の【テーマ】を【Office】に設定
  4. 次に、テーマの【フォント】→一番下の【フォントのカスタマイズ】をクリック
  5. 日本語の見出し、本文フォントを【Meiryo UI】に変更
  6. 最後に、【ホーム】タブ→【名前を付けて保存】
    ブック名：ワークシート比較ツール
    【Excel マクロ有効ブック(*.xlsm)】で【保存】します。
    ※ 上記の設定をしない場合、下記でコードでの【Main】シート作成の際に、列幅が正しく反映されません。

マクロコードの貼り付け

　作成されたMainファイルに標準モジュールを追加します。

  1. 【Alt】＋【F11】キーを押下し、VBE画面を表示
  2. 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成
  3. 下記ボックス内をコピーし、標準モジュールに貼り付け
  4. モジュール名を【B00_MakeMainSht】に変更

マクロコードの実行

　上記、マクロコードの貼り付けが終わったら、いよいよ魔法をかけましょう！

  1. VBE画面、【B00_MakeMainSht】画面の一番上のプロシージャ【Public Sub MakeMainSht】の文字より下で、1度クリックします。
  2. カーソルがそのプロシージャ内に置かれていることを確認します。
  3. 【F5】キーを打鍵するか、リボンにある▶マーク【Sub /ユーザー フォームの実行】ボタンをクリックします。
  4. すると、【Main】シートが作成されているはず！ なのですが、もし、作成されていない場合は、【Ctrl】＋【S】で、ブックを保存し、1度ブックを閉じましょう。
    再度、開きなおし、【マクロを有効】にして、再度、上記の操作を繰り返してみてください。

　G-Tool2-Main-Sht1_WS比較用　につづく

　モジュール名：B00_MakeMainSht
'+++*****************************************************+++
'   ワークシート比較ツール【Main】シートを作成
'+++*****************************************************+++
Public Sub MakeMainSht()
    Dim i As Long
    Dim j As Long
    Dim MaxRow As Long        '最終行
    Dim MaxCol As Long        '最終列
    Dim IngColor As Long
    Dim rHeight() As Variant
    Dim cWidth() As Variant
    Dim strAry1() As Variant
    Dim strAry2() As Variant
    Dim strAry3() As Variant
    Dim strAry4() As Variant
    Dim strAry5() As Variant
    Dim strAry6() As Variant
      
    Dim ColWidth As Double
    Dim bstrWidth As Double
    Dim mgnWidth As Double
    Dim aWdt As Double             'ColumnWidth = 10  :Width
    Dim bWdt As Double             'ColumnWidth = 20  :Width
    Dim cWdt As Double             'ColumnWidth = 1   :Width
    Dim oneDW As Double            'ColumnWidth = 1   :Width
    Dim pOneDw As Double           'ColumnWidth = 0.1 :Width
    Dim myInteger As Double
    Dim myDecimal As Double
    Dim myCW As Double
    
    Dim wbName As String
    Dim MainSht As Worksheet
    Dim IsBlank As Boolean

    Const shtName As String = "Main"
    Const TTLITRCOLOR As Long = 15189684      '薄めの青
    Const TTLSTRCOLOR As Long = 12874308      '青
    Const BGCOLOR As Long = 10192433          '青緑
    Const LGCOLOR As Long = 13285804          'ライトグレー
    Const LBGCOLOR As Long = 11573124         'ライトブルーグレー
    Const LINECOLOR As Long = 10921638        'ライトグレー2

    rHeight = Array(0, 7.5, 35, 7.5, 33, 33, 33, 9.5, 22, 60, 60, 2.5, 36, 15, 15, 16.5, 15, 14.5)
'    cWidth = Array(0, 0.63, 0.63, 27.4, 0.25, 69.93, 0.25, 7.67, 20.67, 0.25, 7.9, 7.9, 5.93)
    cWidth = Array(0, 7.5, 7.5, 210, 3, 529, 3, 38.5, 153.5, 3, 60, 60, 49)
    strAry1 = Array("", "", "ワークシート比較ツール", "", "ひな形ファイル", "保存フォルダ", _
            "比較結果ファイル名", "", "", "比較ファイル ①", "比較ファイル ②")
    Call StopUpdating
    wbName = ActiveWorkbook.Name
'******************************************************************************
    '日本語　フォントテーマをMeiryo UIで設定
    With ActiveWorkbook.Theme.ThemeFontScheme
        .MajorFont.Item(3).Name = "Meiryo UI"      '見出しのフォント
        .MinorFont.Item(3).Name = "Meiryo UI"      '本文のフォント
    End With
'******************************************************************************
    IsBlank = False
    If IsShtOwb(shtName, wbName) = False Then
        With Worksheets(1)
            With .UsedRange
                MaxRow = .Rows(.Rows.Count).Row
                MaxCol = .Columns(.Columns.Count).Column
            End With
        End With
        If MaxRow = 1 And MaxCol = 1 Then
            IsBlank = True
        End If
        If IsBlank Then
            Worksheets(1).Name = shtName
        Else
            ActiveWorkbook.Worksheets.Add Before:=Worksheets(1)
            ActiveSheet.Name = shtName
        End If
    Else
        With ActiveWorkbook.Worksheets(shtName)
            .Select
            .Cells.Clear
        End With
        Call delShapes
    End If

    Set MainSht = ActiveWorkbook.Worksheets(shtName)
    With MainSht
        .Select
        .Cells.VerticalAlignment = xlCenter
        ActiveWindow.FreezePanes = False
        .Cells(3, 2).Select
        ActiveWindow.FreezePanes = True
        ActiveWindow.Zoom = 85
        With .Cells.Font
            .ThemeFont = xlThemeFontNone
            .Name = "Meiryo UI"
            .Size = 11
        End With
        
        '*********************************************

        .Columns(1).ColumnWidth = 10
        .Columns(2).ColumnWidth = 20
        .Columns(3).ColumnWidth = 1

        aWdt = .Columns(1).Width
        bWdt = .Columns(2).Width
        cWdt = .Columns(3).Width
        
        mgnWidth = 2 * aWdt - bWdt
        bstrWidth = (bWdt - aWdt) / 10    'Width/1文字
        oneDW = cWdt
        pOneDw = cWdt / 10

        ''Width/1文字分以上の幅は上記計算通り
        '1文字分以下は計算通りにならない
        'アバウトになるが、1CWあたりのWidthを比例させて使用
        
       '*********************************************
        .Cells.RowHeight = 15#

        For i = 1 To UBound(rHeight)
            .Rows(i).RowHeight = rHeight(i)
        Next i
        For i = 1 To UBound(strAry1)
            .Cells(i, 3).Value = strAry1(i)
        Next i
        .Range("A2:L2").Interior.Color = TTLITRCOLOR
        With .Range("C2").Cells.Font
            .Size = 16
            .Bold = True
            .Color = TTLSTRCOLOR
        End With
        With .Range("C4:C6")
            .Interior.Color = TTLSTRCOLOR
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("C8:C10")
            .Interior.Color = BGCOLOR
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        .Range("C12").BorderAround _
            LineStyle:=xlContinuous, _
            Weight:=xlThin, _
            Color:=LINECOLOR
        With .Range("C4:C10").Font
            .Size = 12
            .Color = vbWhite
            .Bold = True
        End With
        With .Range("E8:H8").Font
            .Size = 12
            .Color = vbWhite
            .Bold = True
        End With
        With .Range("E12:H12").Font
            .Size = 11
            .Color = vbWhite
            .Bold = True
        End With
        .Range("G6").Value = "← 空欄の場合、比較ファイル①の" & _
              vbLf & "ファイル名を使用する。"
        .Range("E8").Value = "ファイルパス名　注意！【比較】ボタン押下時に比較対象ファイルと同名ファイルを開いていた場合は、保存せず閉じます。"
        .Range("E8").Font.Size = 10
        .Range("G8").Value = "比較シート指定"
        .Range("E12").Value = "【差分】【比率】シートの作成 ："
        .Range("G12").Value = "Chk"
        .Range("H12").Value = "比較ファイル ① ： シート名"
        .Range("E8:K8").Interior.Color = BGCOLOR
        .Range("E8:K8").Font.Color = vbWhite
        .Range("E12:E12").Interior.Color = BGCOLOR
        .Range("G12:H12").Interior.Color = BGCOLOR
        .Range("E12:H12").Font.Color = vbWhite
        .Range("E4:I4").Merge
        .Range("E5:I5").Merge
        .Range("G6:I6").Merge
        .Range("E8:F8").Merge
        .Range("G8:I8").Merge
        .Range("J8:K8").Merge
        .Range("E9:F9").Merge
        .Range("G9:I9").Merge
        .Range("E10:F10").Merge
        .Range("G10:I10").Merge
        .Range("J12:K12").Merge
        .Range("J9:J10").Interior.Color = LGCOLOR
        .Range("K9:K10").Interior.Color = LBGCOLOR
        With .Range("E4:I5")
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        .Range("E6:I6").BorderAround _
            LineStyle:=xlContinuous, _
            Weight:=xlThin, _
            Color:=LINECOLOR
        .Range("E6").NumberFormatLocal = """比較_""@""_YYMMDD _hhmm.xlsm"""
        With .Range("C2:H12")
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 1
        End With
        With .Range("E8:K10")
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        .Range("E12").BorderAround _
            LineStyle:=xlContinuous, _
            Weight:=xlThin, _
            Color:=TTLITRCOLOR
        With .Range("G12:H12")
            .VerticalAlignment = xlVAlignTop          '上詰め
            .HorizontalAlignment = xlCenter
            .BorderAround _
            LineStyle:=xlContinuous, _
            Weight:=xlThin, _
            Color:=LINECOLOR
        End With
        .Range("G13").Value = 1
        .ListObjects.Add(xlSrcRange, Range("$G$12:$H$13"), _
             , xlYes).Name = "シート名"
        .ListObjects("シート名").TableStyle = "TableStyleLight11"
        With .Range("J12:K12")
            .Interior.Color = TTLSTRCOLOR
            .BorderAround _
            LineStyle:=xlContinuous, _
            Weight:=xlThin, _
            Color:=LINECOLOR
        End With
        For i = 1 To UBound(cWidth)
            If cWidth(i) > oneDW Then
                myCW = (cWidth(i) - mgnWidth) / bstrWidth
            Else
                myCW = cWidth(i) / oneDW
            End If
            .Columns(i).ColumnWidth = myCW
        Next i
        Call MakeButtons
        Call MakeOptionButtons
        Call MakeOtherShapes
        .Shapes.Range(Array("背景色選択ボックス", "Option 黄", "Option 緑", _
        "Option 青", "黄", "緑", "青")).Group.Name = "optG"
        .Shapes("OptG").Left = .Range("J4").Left + 7.5
        .Shapes.Range(Array("取得1", "取得2", "比較")).Left = .Range("J4").Left + 7
        .Shapes.Range(Array("指定1", "指定2")).Left = .Range("K4").Left + 6
        'メモリ線非表示
        ActiveWindow.DisplayGridlines = False
        .Cells(1, 1).Select
    End With
    Call Updating
End Sub
'+++*****************************************************+++
'   ワークシート比較ツール【Main】シート
'   ボタンを作成
'+++*****************************************************+++
Public Sub MakeButtons()
    Dim nameArray As Variant
    Dim textArray As Variant
    Dim macroArray As Variant
    Dim pstnArray As Variant
    Dim myPosi As Variant
    Dim myBtn As Object
    Dim i As Long
    nameArray = Array("", "比較", "指定２", "取得２", "指定１", _
           "取得１", "選択４", "選択３", "選択２", "選択１")
    textArray = Array("", "比　　　較", "指  定", "取  得", _
        "指  定", "取  得", "選  択", "選  択", "選  択", "選  択")
    macroArray = Array("", "ワークシート比較ツール.xlsm!CompSheets", _
        "ワークシート比較ツール.xlsm!SelectTgt", _
        "ワークシート比較ツール.xlsm!GetShtName", _
        "ワークシート比較ツール.xlsm!SelectTgt", _
        "ワークシート比較ツール.xlsm!GetShtName", _
        "ワークシート比較ツール.xlsm!FilePathSelect", _
        "ワークシート比較ツール.xlsm!FilePathSelect", _
        "ワークシート比較ツール.xlsm!FilePathSelect", _
        "ワークシート比較ツール.xlsm!FilePathSelect")
    pstnArray = Array("0,0,0,0", "992.5,307,106.5,28.5,28.5", _
        "1052.5,257,45.5,28.5,28.5", "992.5,257,45.5,28.5,28.5", _
        "1052.5,197,45.5,28.5,28.5", "992.5,197,45.5,28.5,28.5", _
        "146.5,260.5,54,23.5,23.5", "146.5,200.5,54,23.5,23.5", _
        "146.5,88,54,23,23", "146.5,55,54,23,23")
    With ActiveSheet
        For i = 1 To UBound(nameArray)
            myPosi = Split(pstnArray(i), ",")
            Set myBtn = .Buttons.Add(myPosi(0), _
                                 myPosi(1), _
                                 myPosi(2), _
                                 myPosi(3))
            With myBtn
                .Name = nameArray(i)
                With .Characters             'テキスト
                    .Text = textArray(i)     '文字列
                    .Font.Size = 12          '文字のサイズ
                End With
                .OnAction = macroArray(i)
            End With
        Next i
    End With
End Sub
'+++*****************************************************+++
'   ワークシート比較ツール【Main】シート
'   グループボックス & オプションボタンを作成
'+++*****************************************************+++
Public Sub MakeOptionButtons()
    Dim nameGArray As Variant
    Dim textGArray As Variant
    Dim pstnGArray As Variant
    Dim nameOPArray As Variant
    Dim textOPArray As Variant
    Dim pstnOPArray As Variant
    Dim myPosi As Variant
    Dim myGBox As Object
    Dim myOPBox As Object
    Dim i As Long
    Const LINECOLOR As Long = 10921638        'ライトグレー2
    nameGArray = Array("", "差分シート作成選択ボックス", _
        "背景色選択ボックス")
    textGArray = Array("", " ", " 不一致箇所の背景色 ")
    pstnGArray = Array("0,0,0,0", "228.412,303.5,528.378,35.5", _
        "924.3,50.87,111.5,97.5")
    nameOPArray = Array("", "Option 作成しない", "Option 作成する", _
        "Option 黄", "Option 緑", "Option 青")
    textOPArray = Array("", "  作成しない", "  作成する", "黄", "緑", "青")
    pstnOPArray = Array("0,0,0,0", "512.5,307,75.5,26", _
                "404.5,307.5,75.5,25.5", "933,120,40.5,20", _
                "933,93,40.5,20", "933,66.5,40.5,20")
    With ActiveSheet
        For i = 1 To UBound(nameGArray)
            myPosi = Split(pstnGArray(i), ",")
            Set myGBox = .GroupBoxes.Add(myPosi(0), _
                                 myPosi(1), _
                                 myPosi(2), _
                                 myPosi(3))
            With myGBox
                .Name = nameGArray(i)
                .Characters.Text = textGArray(i)       '文字列
            End With
        Next i
        For i = 1 To UBound(nameOPArray)
            myPosi = Split(pstnOPArray(i), ",")
            Set myOPBox = .OptionButtons.Add(myPosi(0), _
                                 myPosi(1), _
                                 myPosi(2), _
                                 myPosi(3))
            With myOPBox
                .Name = nameOPArray(i)
                .Characters.Text = textOPArray(i)       '文字列
            End With
        Next i
        .Shapes("Option 作成する").Fill.ForeColor.RGB = RGB(255, 255, 255)
        .Shapes("Option 作成する").Fill.Solid
        .Shapes("Option 作成しない").Fill.ForeColor.RGB = RGB(255, 255, 255)
        .Shapes("Option 作成しない").Fill.Solid
    End With
End Sub
'+++*****************************************************+++
'   ワークシート比較ツール【Main】シート
'   その他シェイプを作成
'+++*****************************************************+++
Public Sub MakeOtherShapes()
    Dim name1Array As Variant
    Dim text1Array As Variant
    Dim color1Array As Variant
    Dim pstn1Array As Variant
    Dim name2Array As Variant
    Dim text2Array As Variant
    Dim fSize2Array As Variant
    Dim macro2Array As Variant
    Dim color2Array As Variant
    Dim pstn2Array As Variant
    Dim myPosi As Variant
    Dim myShp As Shape
    Dim i As Long
    
    name1Array = Array("", "黄", "緑", "青")
    text1Array = Array("", "", "", "")
    color1Array = Array("", "65535", "65280", "15773696")
    pstn1Array = Array("0,0,0,0", "975,123.813,50,11.875", _
        "975,97.375,50,11.875", _
        "975,70.75,50,11.875")
    name2Array = Array("", "説明テキスト")
    text2Array = Array("", "ダブルクリックで" & vbCrLf & _
        "　　選択 or 解除    " & ChrW(8600), _
        "Folder" & vbCrLf & "File" & vbCrLf & "Clear ", _
        "Folder" & vbCrLf & "File" & vbCrLf & "Clear ")
    fSize2Array = Array("", "8", "7", "7")
    color2Array = Array("", "10192433 ", "10192433", "12874308")
    macro2Array = Array("", "", "ワークシート比較ツール.xlsm!exeClear", _
        "ワークシート比較ツール.xlsm!exeClear")
    pstn2Array = Array("0,0,0,0", "636.385,304.25,114.24,34.75")

    With ActiveSheet
        For i = 1 To UBound(name1Array)
            myPosi = Split(pstn1Array(i), ",")
            Set myShp = .Shapes.AddShape(msoShapeRectangle, _
                           myPosi(0), myPosi(1), myPosi(2), myPosi(3))
            With myShp
                .Name = name1Array(i)
                .Fill.ForeColor.RGB = color1Array(i)
                .Line.Weight = 0.75
            End With
        Next i
        For i = 1 To UBound(name2Array)
            myPosi = Split(pstn2Array(i), ",")
            Set myShp = .Shapes.AddShape(msoShapeRectangle, _
                           myPosi(0), myPosi(1), myPosi(2), myPosi(3))
            With myShp
                .Name = name2Array(i)
                .Fill.ForeColor.RGB = color2Array(i)
                .Line.Visible = msoFalse
                .Line.Weight = 0.75
                With .TextFrame.Characters          'テキスト
                    .Text = text2Array(i)           '文字列
                    .Font.Size = fSize2Array(i)     '文字のサイズ
                End With
            End With
        Next i
        Call MakeEraser
''　　　　↓テキストボックスから↑消しゴムアイコンに変更
''        With .Shapes.Range(Array("緑Clear"))
''            With .TextFrame2
''                .WordWrap = msoFalse
''                .ParagraphFormat.Alignment = msoAlignCenter
''                .MarginLeft = 0
''                .MarginRight = 0
''                .MarginTop = 0
''                .MarginBottom = 0
''            End With
''        End With
''        With .Shapes.Range(Array("青Clear"))
''            With .ShapeRange.TextFrame2
''                .WordWrap = msoFalse
''                .ParagraphFormat.Alignment = msoAlignCenter
''                .MarginLeft = 0
''                .MarginRight = 0
''                .MarginTop = 0
''                .MarginBottom = 0
''            End With
''        End With
    End With
End Sub
'+++*****************************************************+++
'   消しゴムのアイコンを作成する
'+++*****************************************************+++
Sub MakeEraser()
    Dim myShpA As Object
    Dim myShpB As Object
    Dim myTxtA As Shape
    Dim myTxtB As Shape
    Dim myShp1 As Shape
    Dim myShp2 As Shape
    Dim myLft1 As Double
    Dim myLft2 As Double
    Dim ALft As Double
    Dim BLft As Double
    Dim myTop1 As Double
    Dim myTop2 As Double
    Dim txtHW As Double
    Dim myH1 As Double
    Dim myH2 As Double
    Dim myW1 As Double
    Dim myW2 As Double
    Dim myColorA As Long
    Dim myColorB As Long
    Dim mylColor As Long
    Dim txtColor As Long
    Dim myColor As Long
    Dim i As Long
    Dim strPath As String
    Dim myProc As String
    myLft1 = 200
    myTop1 = 10
    myH1 = 20.9
    myW1 = 11.6
    myLft2 = 220
    myTop2 = 10
    myH2 = 14.7
    myW2 = 12.8
    ALft = 245.5
    BLft = 835.75
    txtHW = 31.18
    myColorA = RGB(68, 114, 196)    '青:12874308
    myColorB = RGB(49, 134, 155)    '緑:10192433
    mylColor = RGB(170, 190, 215)   '枠線カラー:114139050
    txtColor = RGB(39, 60, 84)      'テキストカラー:520423
    myProc = "ワークシート比較ツール.xlsm!exeClear"
    With ActiveSheet
        Set myShp1 = .Shapes.AddShape(msoShapeRectangle, _
                           myLft1, myTop1, myH1, myW1)
        With myShp1
            .Name = "Shp1"
            .Fill.ForeColor.RGB = RGB(255, 255, 255)    '背景色無色
            .Line.Weight = 0.25
            .Line.ForeColor.RGB = mylColor
        End With
        Set myShp2 = .Shapes.AddShape(msoShapeRectangle, _
                           myLft2, myTop2, myH2, myW2)
        With myShp2
            .Name = "Shp2"
            .Fill.ForeColor.RGB = myColorA
            .Line.Weight = 0.25
            .Line.ForeColor.RGB = myColorA
        End With
        With .Shapes.Range(Array("Shp1", "Shp2"))
            .Align msoAlignRights, msoFalse
            .Align msoAlignMiddles, msoFalse
            .Group.Name = "ShpA"
            .Rotation = -40
        End With
        Set myTxtA = .Shapes.AddTextbox(msoTextOrientationHorizontal, _
                        ALft, myTop1, txtHW, txtHW)
        With myTxtA
            .Name = "TxtA"
            .Fill.Visible = msoFalse
            .Line.Weight = 0.25
            .Line.ForeColor.RGB = mylColor              '線色無色
            With .TextFrame
                .HorizontalOverflow = xlOartHorizontalOverflowOverflow
                .VerticalOverflow = xlOartHorizontalOverflowOverflow
            End With
        End With
        With myTxtA.TextFrame2
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            .MarginBottom = 0
            .TextRange.Characters.Text = _
            "Folder" & vbCrLf & "File" & vbCrLf & "Clear "
            .TextRange.Font.Size = 6.5
            .TextRange.Font.Bold = msoTrue
            .TextRange.ParagraphFormat.Alignment = msoAlignCenter
            With .TextRange.Characters(1, 18).Font.Fill
                .Visible = msoFalse
                .ForeColor.RGB = txtColor
            End With
            myTxtA.Line.Visible = msoFalse
        End With
        With .Shapes.Range(Array("ShpA", "TxtA"))
            .Align msoAlignCenter, msoFalse
            .Align msoAlignMiddles, msoFalse
            .Group.Name = "grpA"
        End With
        '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        '.Shapes("grpA").CopyPicture        '画像としてコピー
        '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        .Shapes("grpA").CopyPicture        '画像としてコピー
        .Paste
        Set myShpA = Selection
        myShpA.Name = "青Clear"
        .Shapes("grpA").Delete
        With .Shapes("青Clear")
            .Left = ALft
            .Top = 8
            .OnAction = myProc
        End With
        Set myShp1 = Nothing
        Set myShp2 = Nothing
        Set myTxtA = Nothing
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
        Set myShp1 = .Shapes.AddShape(msoShapeRectangle, _
                           myLft1, myTop1, myH1, myW1)
        With myShp1
            .Name = "Shp1"
            .Fill.ForeColor.RGB = RGB(255, 255, 255)    '背景色無色
            .Line.Weight = 0.25
            .Line.ForeColor.RGB = mylColor
        End With
        Set myShp2 = .Shapes.AddShape(msoShapeRectangle, _
                           myLft2, myTop2, myH2, myW2)
        With myShp2
            .Name = "Shp2"
            .Fill.ForeColor.RGB = myColorB
            .Line.Weight = 0.25
            .Line.ForeColor.RGB = myColorB
        End With
        With .Shapes.Range(Array("Shp1", "Shp2"))
            .Align msoAlignRights, msoFalse
            .Align msoAlignMiddles, msoFalse
            .Group.Name = "ShpB"
            .Rotation = -40
        End With
        Set myTxtB = .Shapes.AddTextbox(msoTextOrientationHorizontal, _
                        BLft, myTop1, txtHW, txtHW)
        With myTxtB
            .Name = "TxtB"
            .Fill.Visible = msoFalse
            .Line.Weight = 0.25
            .Line.ForeColor.RGB = mylColor              '線色無色
            With .TextFrame
                .HorizontalOverflow = xlOartHorizontalOverflowOverflow
                .VerticalOverflow = xlOartHorizontalOverflowOverflow
            End With
        End With
        With myTxtB.TextFrame2
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            .MarginBottom = 0
            .TextRange.Characters.Text = _
            "Folder" & vbCrLf & "File" & vbCrLf & "Clear "
            .TextRange.Font.Size = 6.5
            .TextRange.Font.Bold = msoTrue
            .TextRange.ParagraphFormat.Alignment = msoAlignCenter
            With .TextRange.Characters(1, 18).Font.Fill
                .Visible = msoFalse
                .ForeColor.RGB = txtColor
            End With
            myTxtB.Line.Visible = msoFalse
        End With
        With .Shapes.Range(Array("ShpB", "TxtB"))
            .Align msoAlignCenter, msoFalse
            .Align msoAlignMiddles, msoFalse
            .Group.Name = "grpB"
        End With
        .Shapes("grpB").CopyPicture        '画像としてコピー
        .Paste
        Set myShpB = Selection
        myShpB.Name = "緑Clear"
        .Shapes("grpB").Delete
        With .Shapes("緑Clear")
            .Left = BLft
            .Top = 8
            .OnAction = myProc
        End With
        Set myShp1 = Nothing
        Set myShp2 = Nothing
        Set myTxtB = Nothing
    End With
End Sub

コメント

タイトルとURLをコピーしました