>戻る
'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 '1ページのみ印刷する
End Sub
Sub フォント()
'フォントを、MSPゴシックと明朝を交互に切替えます。
On Error GoTo ErrorHandler
If Selection.Font.Name = "MS Pゴシック" Then
Selection.Font.Name = "MS P明朝"
Else
Selection.Font.Name = "MS Pゴシック"
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
'追加ツール1
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
'追加ツール2
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
>戻る