'Excel Auto_Operate  by かず.A
'
'   経歴
'1.15  2006/05/17：空白を挟んだデータがある場合のバグを修正と、今日の日付を貼り付ける際確認させました。
'1.14  2004/11/24：エラー値を条件付書式で見えなくするマクロと、条件付書式を削除するマクロを追加
'1.13  2004/06/13：枠付けと塗りつぶしのオブジェクトの選択をエラー処理で選択させました。
'1.12  2004/06/12：エラーを表示させました｡
'1.11  2004/02/19：空白を挟んだデータがある場合のバグを修正
'1.10  2004/02/07：縞模様・図の挿入・クイック保護・空白の削除を追加
'1.09  2004/02/07：数字の文字変換コードを見直しました。
'1.08  2003/07/11：複数セル操作可能にしました。（曜日、上付き、下付き）
'1.07  2002/10/18：セルを" "で結合し、セルと文字の分解も出来るようにしました。
'1.06  2002/10/16：セル結合で、選択中の文字の結合も出来るようにしました。
'1.05  2002/08/01：書式に、エクセルあれこれで紹介致しました上付き数字への変換と、下付き数字の変換を追加しました。
'1.04  2002/06/08：選択範囲を図として同位置に貼り付けた後の枠線を元に戻すようにし、ペイントに貼り付けるマクロを削除しました。
'1.03  2002/02/02：セル枠からはみ出ても表示する様、今日の日付を文字表示するようにしました。
'1.02  2002/02/02：セル枠からはみ出ても表示する様、数値の文字表示を追加しました。
'1.01  2001/11/ ：初版

'   ※変数の宣言は強制しておくと､バグが見つけ易くなります｡

Option Explicit
Private MyAddIndentFlag As Boolean    '横位置()：テキストボックスのAddIndentプロパティの代替変数

Sub バー非表示()
    '標準・書式バーを除いて、他のツールバーを非表示にします。
    On Error Resume Next
    Dim i As Integer
    Application.ScreenUpdating = False
    With Application
        For i = 5 To 70
            .CommandBars(i).Visible = False
        Next
        .CommandBars(3).Visible = True
        .CommandBars(4).Visible = True
    End With
    Application.ScreenUpdating = True
End Sub

Sub ズーム()
    'ズーム80％と25％を交互に切替えます。
    '通常の入力は80％で、全体レイアウトは25％で確認出来ます。
    On Error Resume Next
    With ActiveWindow
        If .Zoom > 49 Then
            .Zoom = 25
        Else
            .Zoom = 80
        End If
    End With
End Sub

Sub 印刷()
    'シートの最初の1ページのみ印刷します｡
    On Error Resume Next
    ActiveWindow.SelectedSheets.PrintOut 1, 1, 1, False, ActivePrinter '１ページのみ印刷する
End Sub

Sub フォント()
    'フォントを､MSPゴシックと明朝を交互に切替えます｡
    On Error GoTo ErrorHandler

    If Selection.Font.Name = "ＭＳＰゴシック" Then
      Selection.Font.Name = "ＭＳＰ明朝"
    Else
      Selection.Font.Name = "ＭＳＰゴシック"
    End If
    Exit Sub

ErrorHandler:
    MyErrMsg "フォント切替マクロは実行出来ません。"
End Sub

Sub 横位置()
    '横位置のうち､中央と均等割付､空白の有無を交互に切替えます｡
    'テキストボックス内の切替も出来るように、フラグを使います。
    On Error GoTo ErrorHandler

    If Selection.HorizontalAlignment = xlDistributed Then
        If Selection.AddIndent Or MyAddIndentFlag Then
            Selection.HorizontalAlignment = xlCenter
            MyAddIndentFlag = False
        Else
            Selection.AddIndent = True
            MyAddIndentFlag = True
        End If
    Else
        Selection.HorizontalAlignment = xlDistributed
        Selection.AddIndent = False
        MyAddIndentFlag = False
    End If
    Exit Sub

ErrorHandler:
    MyErrMsg "横位置切替マクロは実行出来ません。"
End Sub

Sub 縦位置()
    '縦位置の上中下､均等割付を交互に切替えます｡
    On Error GoTo ErrorHandler

    Select Case Selection.VerticalAlignment
        Case xlTop
            Selection.VerticalAlignment = xlCenter
        Case xlCenter
            Selection.VerticalAlignment = xlBottom
        Case xlBottom
            Selection.VerticalAlignment = xlDistributed
        Case Else
            Selection.VerticalAlignment = xlTop
    End Select
    Exit Sub

ErrorHandler:
    MyErrMsg "縦位置切替マクロは実行出来ません。"
End Sub

Sub セル結合()
    'セルの結合と解除を､文字の結合と分解を併せて､交互に切替えます｡
    'データのある複数セルを結合する時、アラートをキャンセルするとエラーになる

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    Dim i As Integer
    Dim MyText As String
    Dim MyObject As Range

    If Selection.MergeCells Then
        MyText = Trim(ActiveCell.Value)
        Selection.MergeCells = False
        For Each MyObject In Selection
            i = InStr(MyText, " ")
            If i > 0 Then
                MyObject.Value = Left(MyText, i - 1)
                MyText = Right(MyText, Len(MyText) - i)
            Else
                MyObject.Value = MyText
                MyText = ""
            End If
        Next
    Else
        For Each MyObject In Selection
            MyText = MyText & " " & MyObject.Value
        Next
            With Selection
                .Clear 'ここを削除すると結合前にアラートがでる｡
                .MergeCells = True
                .Value = Trim(MyText)
            End With
    End If
End Sub

Sub 中央()
    'セルの指定範囲内での中央表示と解除を交互に切替えます｡

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    With Selection
        If .HorizontalAlignment <> xlCenterAcrossSelection Then
            .HorizontalAlignment = xlCenterAcrossSelection
        Else
            .HorizontalAlignment = xlLeft
        End If
    End With
End Sub

'テキストボックス関係
Sub 枠付け()
    '周囲の枠の有無を交互に切替えます｡
    On Error GoTo ErrorHandler

    Selection.ShapeRange.Line.Visible = Not (Selection.ShapeRange.Line.Visible)
    Exit Sub

Syori2:
    On Error GoTo SyriOwari
    If Selection.Border.LineStyle = -4105 Then
        Selection.Border.LineStyle = 0
    Else
        Selection.Border.LineStyle = -1
    End If
    Exit Sub

ErrorHandler:
    Resume Syori2
SyriOwari:
    MyErrMsg "枠付け切替マクロは実行出来ません。"
End Sub

Sub 塗りつぶし()
    '塗りつぶしの有無を交互に切替えます｡
    On Error GoTo ErrorHandler

    Selection.ShapeRange.Fill.Visible = Not (Selection.ShapeRange.Fill.Visible)
    Exit Sub

Syori2:
    On Error GoTo SyriOwari
    If Selection.Interior.ColorIndex = xlAutomatic Then
        Selection.Interior.ColorIndex = xlNone
    Else
        Selection.Interior.ColorIndex = xlAutomatic
    End If
    Exit Sub

ErrorHandler:
    Resume Syori2
SyriOwari:
    MyErrMsg "塗りつぶし切替マクロは実行出来ません。"
End Sub

Sub バリエーション()
    '塗りつぶしの内､1色でのグラデーションを追加します｡
    On Error GoTo ErrorHandler
    Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 1, 0.23
    Exit Sub
ErrorHandler:
    MyErrMsg "グラデーションマクロは実行出来ません。"
End Sub

Sub 角丸()
    '角のアールの有無を交互に切替えます｡
    On Error GoTo ErrorHandler
    Selection.RoundedCorners = Not (Selection.RoundedCorners)
    Exit Sub
ErrorHandler:
    MyErrMsg "角丸切替マクロは実行出来ません。"
End Sub

Sub 自動サイズ()
    '配置の自動サイズ調整を有効にします｡
    On Error GoTo ErrorHandler
    Selection.AutoSize = True
    Exit Sub
ErrorHandler:
    MyErrMsg "自動サイズマクロは実行出来ません。"
End Sub

'書式関係
Sub 縞模様()
    '条件付き書式を使って、偶数列セルの背景を灰色にする
    On Error Resume Next
    Dim MyMsg As String
    Dim ragSyoriCell As Range

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    Application.ScreenUpdating = False
    If Selection.Count > 1 Then
        Set ragSyoriCell = Selection.SpecialCells(xlCellTypeAllFormatConditions)
    Else
        If Selection.FormatConditions.Count > 0 Then
            Set ragSyoriCell = Selection
        End If
    End If

    On Error GoTo 0
    On Error GoTo ErrorHandler
    If Not (ragSyoriCell Is Nothing) Then
        'すでに条件付書式が設定されていれば、条件付書式を削除する
        MyMsg = "選択された範囲内に、" & Format(ragSyoriCell.Count, "#,##0" & " 個のセルに条件付書式が設定されています。") _
            & vbCrLf & vbCrLf & "該当するセル( " & ragSyoriCell.Address(ColumnAbsolute:=False, RowAbsolute:=False) & _
                " )" & vbCrLf & "の条件付書式を削除し、縞模様の書式を設定しても良いですか？"
        If KakuninMsg(MyMsg) = vbNo Then
            GoTo SyoriEnd '処理を終える
        End If
    End If

    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=MOD(ROW(),2)=0" '偶数行を対象
    Selection.FormatConditions(1).Interior.ColorIndex = 15 'ライトグレー
SyoriEnd:
    Set ragSyoriCell = Nothing
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    MyErrMsg "条件書式を削除するマクロは実行出来ません。"
    Resume SyoriEnd
End Sub

Sub 表題()
    '表題に適したフォントにします｡ (サイズ16 + 斜体 + 下線付き)
    On Error GoTo ErrorHandler

    With Selection.Font
        .Size = 16
        .Italic = True
        .Underline = xlUnderlineStyleSingle
SyoriEnd:
    End With
    Exit Sub
ErrorHandler:
    MyErrMsg "表題フォントマクロは実行出来ません。"
    Resume SyoriEnd
End Sub

Sub 曜日書式()
    '日付を曜日表示にします｡ (条件付書式で､土日の表示を変化させます｡)
    On Error GoTo ErrorHandler
    Dim Celladd As String

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    With Selection
        Celladd = Cells(.Row, .Column).AddressLocal(RowAbsolute:=False, ColumnAbsolute:=False)
        .NumberFormatLocal = "aaa"
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=WEEKDAY(" & Celladd & ")=1"
        .FormatConditions(1).Font.ColorIndex = 3
        .FormatConditions(1).Interior.ColorIndex = 15
        .FormatConditions.Add Type:=xlExpression, Formula1:="=WEEKDAY(" & Celladd & ")=7"
        .FormatConditions(2).Font.ColorIndex = 5
        .FormatConditions(2).Interior.ColorIndex = 15
        .HorizontalAlignment = xlCenter
SyoriEnd:
    End With
    Exit Sub
ErrorHandler:
    MyErrMsg "曜日書式マクロは実行出来ません。"
    Resume SyoriEnd
End Sub

Sub 日()
    '日付を日表示にします｡
    '（工程表などにお使い下さい。）
    On Error GoTo ErrorHandler

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    Selection.NumberFormatLocal = "d"
    Exit Sub

ErrorHandler:
    MyErrMsg "日付書式マクロは実行出来ません。"
End Sub

Sub 日付()
    '本日の日付を､和暦文字で貼り付けます｡
    On Error GoTo ErrorHandler

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    If ActiveCell.Value <> "" Then
        If KakuninMsg("本日の日付に置き換えても良いですか？") = vbNo Then
            Exit Sub
        End If
    End If

    ActiveCell.Value = Format(Now(), "'ggge年m月d日")
    Exit Sub

ErrorHandler:
    MyErrMsg "日付貼り付けマクロは実行出来ません。"
End Sub

Sub 上付き()
    'セル内の冒頭以外数字を上付きに書式を変換します。単位等に使用できます。
    On Error GoTo ErrorHandler
    Dim MyValue As String
    Dim MyLen As Long
    Dim MyPos As Long
    Dim ragSyoriCell As Range
    Dim strLastCell As String

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    strLastCell = Selection.SpecialCells(xlCellTypeLastCell).Address
    For Each ragSyoriCell In Selection
        MyValue = ragSyoriCell.Value
        If IsNull(MyValue) Then Exit Sub
        MyLen = Len(MyValue)

        For MyPos = 1 To MyLen
            If Not (IsNumeric(Left(MyValue, MyPos))) Then '初めの数値は除外
                If IsNumeric(Mid(MyValue, MyPos, 1)) Then
                    ragSyoriCell.Characters(Start:=MyPos, Length:=1).Font.Superscript = True
                End If
            End If
        Next MyPos

        If ragSyoriCell.Address = strLastCell Then
            Exit Sub
        End If

    Next
    Exit Sub
ErrorHandler:
    MyErrMsg "上付き書式マクロは実行出来ません。"
End Sub

Sub 下付き()
    'セル内の冒頭以外数字を下付きに書式を変換します。化学式に使用できます。
    On Error GoTo ErrorHandler
    Dim MyValue As String
    Dim MyLen As Long
    Dim MyPos As Long
    Dim ragSyoriCell As Range
    Dim strLastCell As String

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    strLastCell = Selection.SpecialCells(xlCellTypeLastCell).Address
    For Each ragSyoriCell In Selection
        MyValue = ragSyoriCell.Value
        If IsNull(MyValue) Then Exit Sub
        MyLen = Len(MyValue)

        For MyPos = 1 To MyLen
            If Not (IsNumeric(Left(MyValue, MyPos))) Then '初めの数値は除外
                If IsNumeric(Mid(MyValue, MyPos, 1)) Then
                    ragSyoriCell.Characters(Start:=MyPos, Length:=1).Font.Subscript = True
                End If
            End If
        Next MyPos

        If ragSyoriCell.Address = strLastCell Then
            Exit Sub
        End If
    Next
    Exit Sub
ErrorHandler:
    MyErrMsg "下付き書式マクロは実行出来ません。"
End Sub

Sub 文字変換()
    'セル内の数値を､表示形式にまま文字として貼り付けます｡
    On Error GoTo ErrorHandler
    Dim ragSyoriCell As Range
    Dim strLastCell As String
    Dim strMsg As String
    Dim RetuHaba As Integer

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    Application.ScreenUpdating = False
    strLastCell = Selection.SpecialCells(xlCellTypeLastCell).Address
    For Each ragSyoriCell In Selection
        If Left(ragSyoriCell.Formula, 1) = "=" Then
            strMsg = ragSyoriCell.Address & "内は数式です。" & vbCrLf & _
                "数式を文字に変換する場合は、「はい」を" & vbCrLf & _
                    "値を文字に変換する場合は、「いいえ」を" & vbCrLf & _
                        "何もしない場合は、「キャンセル」を押して下さい。"

            Select Case MsgBox(strMsg, vbYesNoCancel)
                Case 2: GoTo SyoriPath
                Case 6: ragSyoriCell.Value = "'" & ragSyoriCell.Formula
                Case 7: GoTo AtaiSyori
            End Select
        Else
AtaiSyori:
            If (IsNumeric(ragSyoriCell.Value) Or IsDate(ragSyoriCell.Value)) And ragSyoriCell.Value <> "" Then  ' (IsNumeric(ragSyoriCell.Value) Or IsDate(ragSyoriCell.Value) AndragSyoriCell.Value <> ""
                If ragSyoriCell.NumberFormatLocal = "G/標準" Then
                    ragSyoriCell.Value = "'" & ragSyoriCell.Value
                Else
                    If InStr(ragSyoriCell.Text, "#") > 0 Then
                        With ragSyoriCell
                            RetuHaba = .ColumnWidth
                            .EntireColumn.AutoFit
                            .Value = "'" & .Text
                            .ColumnWidth = RetuHaba
                        End With
                    Else
                        ragSyoriCell.Value = "'" & ragSyoriCell.Text
                    End If
                End If
            End If
        End If
SyoriPath:
        If ragSyoriCell.Address = strLastCell Then GoTo Syuryou
    Next
SyoriEnd:
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    MyErrMsg "文字変換マクロは実行出来ません。"
    Resume SyoriEnd
End Sub

Sub 点付き()
    '数値末尾に点をつけます｡
    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    Selection.NumberFormatLocal = "0."
End Sub

Sub かっこ付き()
    'カッコの付いた数値表示にします｡
    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    Selection.NumberFormatLocal = "(0)"
End Sub

'追加ツール１
Sub 縦横切替()
    'セル内の縦書き､横書きを交互に切替えます｡
    On Error GoTo ErrorHandler
    With Selection
        If .Orientation = xlVertical Then
            .Orientation = xlHorizontal
        Else
            .Orientation = xlVertical
        End If
    End With
    Exit Sub

ErrorHandler:
    MyErrMsg "縦横切替マクロは実行出来ません。"
End Sub

Sub ウィンドウ()
    'ワンタッチで､ウィンドウを並べて表示します｡
    On Error Resume Next
    Windows.Arrange ArrangeStyle:=xlTiled
End Sub

Sub IME_ON()
    'セルの入力規制でIMEをひらがなにします｡
    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IMEMode = xlIMEModeHiragana
    End With
End Sub

Sub IME_OFF()
    'セルの入力規制でIMEを直接入力にします｡
    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IMEMode = xlIMEModeNoControl
    End With
End Sub

Sub カーソル右()
    'Enterキーを押した後のカーソル移動先を右にします｡
    On Error Resume Next
    Application.MoveAfterReturn = True
    Application.MoveAfterReturnDirection = xlToRight
End Sub

Sub カーソル下()
    'Enterキーを押した後のカーソル移動先を下にします｡
    On Error Resume Next
    Application.MoveAfterReturn = True
    Application.MoveAfterReturnDirection = xlDown
End Sub

Sub カーソル不動()
    'Enterキーを押してもカーソルを移動しません｡
    On Error Resume Next
    Application.MoveAfterReturn = False
End Sub

'追加ツール２
Sub バージョン()
    'バージョン情報…これは不要ですね、他にマクロを組んで見て下さい。
    On Error Resume Next
    MsgBox "Excel Auto_Operate 1.15   by かず.A"
End Sub

Sub 定数以外保護()
    '定数が入力されたセル以外のセルを保護する。
    On Error GoTo ErrorHandler
    Dim MyRange As Range
    Dim MyPass As String
    Dim KkuninMsgStr As String

    If ActiveSheet.ProtectContents Then
        KkuninMsgStr = " このシートは保護されてます。" & vbCrLf & " 保護を解除しても良いですか？"
        If KakuninMsg(KkuninMsgStr) = vbYes Then
            ActiveSheet.Unprotect
            Cells.Locked = True
        End If
    Else
        Set MyRange = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 23)
        KkuninMsgStr = "シートは未保護です。" & vbCrLf & "定数を除き、保護しても良いですか？"
        If KakuninMsg(KkuninMsgStr) = vbYes Then
            KkuninMsgStr = "必要ならパスワードを入力して下さい。" & vbCrLf & _
                    vbCrLf & "空白を入力するか、キャンセルを押すと" & vbCrLf & _
                            "パスワードは設定されません。"
            MyPass = InputBox(KkuninMsgStr, "クイック保護のパスワード入力")
            Cells.Locked = True
            MyRange.Locked = False
            Set MyRange = Nothing
            ActiveSheet.Protect DrawingObjects:=True, _
                    Contents:=True, Scenarios:=True, Password:=MyPass
            ActiveSheet.EnableSelection = xlUnlockedCells
        End If
    End If
    Exit Sub

ErrorHandler:
    MyErrMsg "クイック保護マクロは実行出来ません。"
    Set MyRange = Nothing
End Sub

Sub 前後の空白を削除()
    'セル内データの前後の空白を削除します。
    '2004/2/19 空白を挟んだデータがある場合のバグを修正
    '2006/5/17 選択範囲を文字列セルに限定

    Dim MyRange As Range
    Dim myAddress As String

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    Application.ScreenUpdating = False
    With Selection.SpecialCells(xlCellTypeConstants, xlTextValues)
        Set MyRange = .Find(What:=" ", LookIn:=xlValues, MatchByte:=False)
        If Not MyRange Is Nothing Then
            myAddress = MyRange.Address
            Do
                '最初に見付かったセルを処理せずに、最後に処理してループを抜ける。
                Set MyRange = .FindNext(MyRange)
                MyRange.Value = Trim(MyRange.Value)
            Loop While MyRange.Address <> myAddress
            Set MyRange = Nothing
        End If
    End With
    Application.ScreenUpdating = True
End Sub

Sub 図にコピー()
    '選択範囲を､図として同位置に貼り付けます｡

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    Application.ScreenUpdating = False
    Dim WakuSen As Boolean '枠線の有無を記録し前の状態に戻す

    WakuSen = ActiveWindow.DisplayGridlines
    ActiveWindow.DisplayGridlines = False '図にした時の枠線を消しておく
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ActiveSheet.Pictures.Paste.Select
    ActiveWindow.DisplayGridlines = WakuSen
    Selection.ShapeRange.Fill.Visible = msoTrue
    Application.ScreenUpdating = True

End Sub

Sub コメント図()
    'セルのコメントの背景に図を挿入する
    On Error GoTo ErrorHandler
    Dim MyMsg As String
    Dim MyComment As Comment
    Dim checkCom As Boolean

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    Else
        If Selection.Cells.Count > 1 Then '単独セルの選択を判断する
            MyErrMsg "複数のセルには挿入出来ません"
            Exit Sub '複数のセルが選択されている場合は終了する
        End If
    End If

    Set MyComment = Selection.Comment
    checkCom = Not (MyComment Is Nothing)
    Set MyComment = Nothing
    If checkCom Then
        MyMsg = "選択されたセルには、コメントが挿入されています。" _
            & vbCrLf & "新しいコメントに、書きかえて良いですか？"
        If KakuninMsg(MyMsg) = vbNo Then
            Exit Sub
        End If
    End If

    MyMsg = MyImgFile()
    If MyMsg <> "" Then
        If checkCom Then 'True=「セルにコメントがあり削除する」
            ActiveCell.ClearComments
        End If
        ActiveCell.AddComment Text:=""
        With ActiveCell.Comment.Shape
            .Fill.UserPicture MyMsg
            .Line.Visible = msoFalse
            .Shadow.Visible = msoFalse
            .ScaleWidth 2.2, msoFalse, msoScaleFromTopLeft
            .ScaleHeight 2.5, msoFalse, msoScaleFromTopLeft
'            .Visible = msoTrue'コメントを挿入後、表示する
        End With
    End If
    Exit Sub

ErrorHandler:
    MyErrMsg "コメントの背景に図を挿入出来ません。"
End Sub

Sub オートシェイプに図()
    'オートシェイプの背景に図を挿入する
    On Error GoTo ErrorHandler
    Dim MyMsg As String

    Select Case TypeName(Selection) '単独に実行した場合の確認
        Case "Rectangle" 'オートシェイプ
        Case "Oval" 'オーバル
        Case "TextBox" 'テキストボックス
        Case "Picture" '図
        Case "GroupObject" 'グループオブジェクト
        Case Else
            MyErrMsg "オートシェイプや、テキストボックス等を選択して下さい"
            Exit Sub '選択されていない場合は終了する
    End Select

    MyMsg = MyImgFile()
    If MyMsg <> "" Then
        Selection.ShapeRange.Fill.UserPicture MyMsg
    End If
    Exit Sub

ErrorHandler:
    MyErrMsg "オートシェイプの背景に図を挿入出来ません。"
End Sub

Sub エラー値を隠す()
'------------------------------------------------
'エラー値を隠す
'------------------------------------------------
    On Error GoTo ErrorHandler
    Dim myAddress As String
    Dim ragSyoriCell As Range

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    If Selection.Count > 1 Then
        Set ragSyoriCell = Selection.SpecialCells(xlCellTypeFormulas, 16)
    Else
        If IsError(Selection) Then
            Set ragSyoriCell = Selection
        Else
            Error 1004 '強制的にエラーを発生させ処理を終える
        End If
    End If

    If KakuninMsg("選択された範囲内に、" & Format(ragSyoriCell.Count, "#,##0") & " 個のセルに、エラー値が確認されました。" _
        & vbCrLf & "条件付書式で、セル値がエラーの時、文字色を白色なるように設定します。" _
            & vbCrLf & vbCrLf & "（注意：既に条件付書式が設定してある場合、既設の条件付書式は全て削除されます。）" _
                & vbCrLf & vbCrLf & "処理しても良いですか？") = vbNo Then
        Exit Sub
    End If

    ragSyoriCell.FormatConditions.Delete
    myAddress = Selection.Range("A1").Address(False, False, xlA1)
    With ragSyoriCell
        .FormatConditions.Add _
            Type:=xlExpression, Formula1:="=ISERROR(" & myAddress & ")"
        .FormatConditions(1).Font.ColorIndex = 2
    End With
SyoriEnd:
    Set ragSyoriCell = Nothing
    Exit Sub

ErrorHandler:
    MyErrMsg "エラー処理書式マクロは実行出来ません。"
    Resume SyoriEnd
End Sub

Sub 条件書式を削除()
    ' 条件付き書式を削除する
    On Error GoTo ErrorHandler
    Dim ragSyoriCell As Range
    Dim strMsg As String

    If SelectCheck(Selection) Then
        Exit Sub 'セル以外が選択された場合は終わる
    End If

    If Selection.Count > 1 Then
        Set ragSyoriCell = Selection.SpecialCells(xlCellTypeAllFormatConditions)
    Else
        If Selection.FormatConditions.Count > 0 Then
            Set ragSyoriCell = Selection
        Else
            Error 1004 '強制的にエラーを発生させ処理を終える
        End If
    End If

    strMsg = "選択された範囲内に、" & Format(ragSyoriCell.Count, "#,##0" & " 個のセルに条件付書式が設定されています。") _
        & vbCrLf & vbCrLf & "該当するセル( " & ragSyoriCell.Address(ColumnAbsolute:=False, RowAbsolute:=False) & _
            " )" & vbCrLf & "の条件付書式を、削除しても良いですか？"

    If KakuninMsg(strMsg) = vbYes Then
        ragSyoriCell.FormatConditions.Delete
    End If
SyoriEnd:
    Set ragSyoriCell = Nothing
    Exit Sub

ErrorHandler:
    MyErrMsg "条件書式を削除するマクロは実行出来ません。"
    Resume SyoriEnd
End Sub

Private Function MyImgFile() As String
    'ファイル名を参照するダイアログを開き、画像ファイル名を返すサブプロシージャ
    Dim MyFile As FileDialog

    Set MyFile = Application.FileDialog(msoFileDialogFilePicker)
    With MyFile
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "イメージファイル", "*.bmp;*.gif; *.jpg; *.jpeg", 1
        .Filters.Add "画像ファイル", "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.bmz;*.gif;*.gfa;*.emz;*.wmz;*.pcz;*.pcd;*.pcx;*.cgm;*.eps;*.fpx;*.jah;*.jbh", 2
    End With
    If MyFile.Show Then
        MyImgFile = MyFile.SelectedItems(1)
    End If
    Set MyFile = Nothing
End Function

Private Sub MyErrMsg(MsgStr As String)
    '処理メッセージを統一。
    If Err.Number Then
        MsgStr = Err.Description & vbCrLf & vbCrLf & MsgStr
    End If
    MsgBox MsgStr, vbExclamation, "Auto_Operate"
End Sub

Private Function KakuninMsg(MsgStr As String) As Long
'確認メッセージを統一。
KakuninMsg = MsgBox(MsgStr, vbYesNo + vbExclamation + vbDefaultButton2, "Auto_Operate")
End Function

Private Function SelectCheck(Taisyo As Variant) As Boolean
    '選択範囲を確認し、Range 以外ならTrueを返す。
    SelectCheck = (TypeName(Taisyo) <> "Range")
    If SelectCheck Then
        MyErrMsg "セル以外が選択されてます。" & vbCrLf & vbCrLf & _
            "対象とするセルを選択して、実行して下さい。"
    End If
End Function

Sub AUTO_CLOSE()
    '新しく作成したツールバーは､閉じる時に必ず削除します
    On Error Resume Next 'バーが非表示の場合、エラーとなるため
    Application.CommandBars("Auto_Operate").Delete
End Sub

＞戻る