選択範囲の金額を千円単位にする（四捨五入版）
タイトルのとおり選択範囲の金額を千円単位に変換し、小数点以下を四捨五入します。
ちなみに、下記のコードでは小数点以下を四捨五入ますが、小数点以下を切り上げたり切り捨てしたい場合もあると思いますのでそっちのバージョンも作ってみました。コード後のリンクから飛べます。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 選択範囲の金額を千円単位にする四捨五入版()
Dim myRange As Range
For Each myRange In Selection
If myRange.Value <> 0 And myRange.Value <> "" And _
TypeName(myRange.Value) <> "String" And TypeName(myRange.Value) <> "Date" Then
'セルの値が0,空白,文字列,日付のいづれかの場合は処理をしない
myRange.Value = Round(myRange.Value / 1000, 0) '小数点以下は四捨五入
End If
Next myRange
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
切り捨て版はこちら
切り上げ版はこちら
選択範囲の金額を千円単位にする（切り捨て版）
タイトルのとおり選択範囲の金額を千円単位に変換し、小数点以下を切り捨てします。
ちなみに、下記のコードでは小数点以下を切り捨てますが、小数点以下を切り上げたり四捨五入したい場合もあると思いますのでそっちのバージョンも作ってみました。コード後のリンクから飛べます。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 選択範囲の金額を千円単位にする切り捨て版()
Dim myRange As Range
For Each myRange In Selection
If myRange.Value <> 0 And myRange.Value <> "" And _
TypeName(myRange.Value) <> "String" And TypeName(myRange.Value) <> "Date" Then
'セルの値が0,空白,文字列,日付のいづれかの場合は処理をしない
myRange.Value = Application.RoundDown(myRange.Value / 1000, 0) '小数点以下は切り捨て
End If
Next myRange
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
切り上げ版はこちら
四捨五入版はこちら
選択範囲の金額を千円単位にする（切り上げ版）
タイトルのとおり選択範囲の金額を千円単位に変換し、小数点以下を切り上げします。以前に掲載した内容と重複しますが前回のコードでは下の画像のような飛び飛びのセル選択に対して正しく処理ができなかったためFor Each Nextでコードを書き直しました。
前回のコードはこちら
ちなみに、下記のコードでは小数点以下を切り上げますが、小数点以下を切り捨てたり四捨五入したい場合もあると思いますのでそっちのバージョンも用意してみました。コード後のリンクから飛べます。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 選択範囲の金額を千円単位にする切り上げ版()
Dim myRange As Range
For Each myRange In Selection
If myRange.Value <> 0 And myRange.Value <> "" And _
TypeName(myRange.Value) <> "String" And TypeName(myRange.Value) <> "Date" Then
'セルの値が0,空白,文字列,日付のいづれかの場合は処理をしない
myRange.Value = Application.RoundUp(myRange.Value / 1000, 0) '小数点以下は切り上げ
End If
Next myRange
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
切り捨て版はこちら
四捨五入版はこちら
指定した文字のみ色を変える
ある特定の文字のみ色を変えるマクロです。たとえば下のような「松島」という文字のみ色を変えたい場合に･･････
色を変更したい文字が入ったセル範囲を選択した状態で、マクロを実行して下さい。
ちなみに、非表示やフィルタリングによって折りたたまれたセルには処理を行いません。（可視セルにのみ処理を行う）
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 指定した文字の色を変える()
Dim sm As Variant
Dim ci As Variant
Dim r As Range
Dim i As Integer
smr:
sm = Application.InputBox(Prompt:="色を変える文字を指定して下さい", Type:=2)
If TypeName(sm) = "Boolean" Then
Exit Sub
ElseIf sm = "" Then
GoTo smr
End If
cir:
ci = Application.InputBox(Prompt:="色を選んで下さい" _
& vbCrLf & "1:黒" & vbCrLf & "2:白" & vbCrLf & "3:赤" & vbCrLf & _
"4:明るい緑" & vbCrLf & "5:青" & vbCrLf & "6:黄色" & vbCrLf & _
"7:ピンク" & vbCrLf & "8:水色" & vbCrLf & "9:明るい赤" & vbCrLf & _
"10:緑" & vbCrLf & "(11以降の色番号はVBAのヘルプ等で確認下さい)", Type:=1)
If TypeName(ci) = "Boolean" Then
Exit Sub
ElseIf ci < 1 Or ci > 56 Then
MsgBox "1～56の数値で入力して下さい"
GoTo cir
End If
For Each r In Selection.SpecialCells(xlCellTypeVisible)
i = 1
Do While i <= Len(r)
If InStr(i, r, sm) > 0 Then
r.Characters(InStr(i, r, sm), Len(sm)) _
.Font.ColorIndex = ci
i = InStr(i, r, sm) + Len(sm)
Else
Exit Do '永久ループを回避
End If
Loop
Next r
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
コマンドバーのリスト表示
以下はコマンドバー（コマンドバーコントロールの上位階層にあたるもの）の一覧をリスト表示するコードです。マイクロソフトのヘルプページにあるものです（使い勝手のいいよう少し改良しました）。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub GetCommandbarInfo()
Dim AppCmdBar As CommandBar
Dim i As Integer
i = 0
For Each AppCmdBar In Application.CommandBars
i = i + 1
'インデックス番号の取得
Cells(i, 1) = AppCmdBar.Index
'コマンドバーの名前の取得
Cells(i, 2) = AppCmdBar.Name
'コマンドバーの種類の取得
Select Case AppCmdBar.Type
Case 0
Cells(i, 3) = "msoBarTypeNomal"
Case 1
Cells(i, 3) = "msoBarTypeMenuBar"
Case 2
Cells(i, 3) = "msoBarTypePopup"
End Select
Next AppCmdBar
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
コマンドバーコントロール（Cell）のリスト表示
右クリック時のショートカットメニューにマクロを登録する際、上から何番目にメニューを配置するか指定できますが、EXCELの標準で隠されたメニューなどがあるため、正しい順番が分からないことがあります。
その際には下記のマクロで右クリック(Cell用）ショートカットメニューのすべてをリスト表示することができます。これはマイクロソフトのヘルプページにあるコマンドバーのリスト化のマクロをCell用に改良したものです。実行すると、A1～C1列にリストが表示されるので、何もない空白のSheetなどで実行してください。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub Cell用コマンドバーコントロールの情報を取得()
Dim i As Integer
For i = 1 To Application.CommandBars("Cell").Controls.Count
'インデックス番号の取得
Cells(i, 1) = Application.CommandBars("Cell").Controls(i).Index
'Cell用コマンドバーコントロールの名前の取得
Cells(i, 2) = Application.CommandBars("Cell").Controls(i).Caption
'Cell用コマンドバーコントロールの種類の取得
Select Case Application.CommandBars("Cell").Controls(i).Type
Case 1
Cells(i, 3) = "msoControlButton"
Case 10
Cells(i, 3) = "msoControlPopup"
End Select
Next
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
以下の記事にオリジナルのコードを紹介しています。
右クリックショートカットメニューにマクロを登録
こんな感じで、右クリックした時のショートカットメニューにマクロを登録できたらいいなと思ったので、下記のようなマクロを作ってみました。対話形式で好きなマクロを右クリックのショートカットメニューに登録することができます。失敗してもリセットし、初期状態に戻せるようになっているので怖がらずに試してみて下さい。このマクロのカラクリについては後日改めて記載してみたいと思います。
使用する前に以下の点に目を通していただけると幸いです。
・単一のセルまたはセル範囲を選択している状態で右クリックした時のメニューを追加できます。
・列または行を選択している時の右クリックメニューには追加されません。
・特別な設定等をされているBook（Sheet）では使用できない場合があります。
・ショートカットメニューに登録するマクロは「個人用マクロブック」にあるといつでも呼び出せるので便利です。
・メニューやサブメニューを削除する際、存在しない名称を記入したり、名称を間違えるとエラーとなります。
・サブメニューを作成する際、上位階層のメニュー名に存在しない名称を記入したり、名称を間違えるとエラーとなります。
・登録するマクロ名は、Sub マクロ１ ()の「マクロ１」の部分を入力して下さい。
・マクロ名を間違えたり、存在しないマクロ名を入力すると、メニューからマクロを起動する際にエラーになります。
・マクロ名を間違えた場合は、該当のメニューまたはサブメニューを削除して再度追加し直して下さい。
・サブメニューを作成できるのは第二階層までです。第三階層以降の作成には対応していません。
・下記のマクロは保存しなくても、追加したショートカットメニューが消えることはありません。追加、削除、リセットはマクロからのみ行えます。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Sub 右クリックショートカットメニューにマクロを登録()
'このマクロ自体をメニューまたはサブメニューから呼び出している場合は、該当のメニューまたはサブメニューの削除はできません
Dim sn As Variant
Dim ct As Variant
Dim bf As Variant
Dim oa As Variant
Dim bg As Variant
Dim cts As Variant
Dim myButton As CommandBarButton
Dim myPopup As CommandBarPopup
sn = Application.InputBox(Prompt:="処理内容を選択して下さい" & vbCrLf & "1:メニューの追加" & _
vbCrLf & "2:サブメニューを含むメニューの追加" & vbCrLf & "3:サブメニューの追加" & vbCrLf & _
"4:メニューの削除" & vbCrLf & "5:サブメニューの削除" & vbCrLf & "6:初期状態に戻す（リセット）", Type:=1)
Select Case sn
Case 1
ctr:
ct = Application.InputBox(Prompt:="メニュー名を入力して下さい", Type:=2)
If TypeName(ct) = "Boolean" Then
Exit Sub
ElseIf ct = "" Then
GoTo ctr
End If
oar:
oa = Application.InputBox(Prompt:="メニューに登録するマクロ名を入力して下さい", Type:=2)
If TypeName(oa) = "Boolean" Then
Exit Sub
ElseIf oa = "" Then
GoTo oar
End If
bfr:
bf = Application.InputBox(Prompt:="メニューを上から何番目に配置しますか？（0で末尾）", Type:=1)
If TypeName(bf) = "Boolean" Then
Exit Sub
ElseIf bf = 0 Then
Set myButton = CommandBars("Cell").Controls.Add
ElseIf bf >= 1 And bf <= CommandBars("Cell").Controls.Count Then
Set myButton = CommandBars("Cell").Controls.Add(Before:=bf) 'Before:=で配置位置を指定する。省略で末尾に配置
Else
MsgBox "0～" & CommandBars("Cell").Controls.Count & "の数値で入力して下さい"
GoTo bfr
End If
myButton.Caption = ct '追加するメニュー名を入力
myButton.OnAction = oa '実行するマクロ名を入力
bgr:
bg = Application.InputBox(Prompt:="メニューの上側に区切り線を入れますか？" & vbCrLf & _
"1:入れる" & vbCrLf & "2:入れない", Type:=1)
If TypeName(bg) = "Boolean" Then
Exit Sub
ElseIf bg = 1 Then
myButton.BeginGroup = True 'Trueで上側に区切り線が表示される。Falseで区切り線なし
ElseIf bg = 2 Then
myButton.BeginGroup = False
Else
MsgBox "1または2を入力して下さい！"
GoTo bgr
End If
Case 2
ctrr:
ct = Application.InputBox(Prompt:="サブメニューを含むメニュー名を入力して下さい", Type:=2)
If TypeName(ct) = "Boolean" Then
Exit Sub
ElseIf ct = "" Then
GoTo ctrr
End If
bfrr:
bf = Application.InputBox(Prompt:="サブメニューを含むメニューを上から何番目に配置しますか？（0で末尾）", Type:=1)
If TypeName(bf) = "Boolean" Then
Exit Sub
ElseIf bf = 0 Then
Set myPopup = CommandBars("Cell").Controls.Add(Type:=msoControlPopup)
ElseIf bf >= 1 And bf <= CommandBars("Cell").Controls.Count Then
Set myPopup = CommandBars("Cell").Controls.Add(Type:=msoControlPopup, Before:=bf) 'Before:=で配置位置を指定する。省略で末尾に配置
Else
MsgBox "0～" & CommandBars("Cell").Controls.Count & "の数値で入力して下さい"
GoTo bfrr
End If
myPopup.Caption = ct '追加するメニュー名を入力
bgrr:
bg = Application.InputBox(Prompt:="サブメニューを含むメニューの上側に区切り線を入れますか？" & vbCrLf & _
"1:入れる" & vbCrLf & "2:入れない", Type:=1)
If TypeName(bg) = "Boolean" Then
Exit Sub
ElseIf bg = 1 Then
myPopup.BeginGroup = True 'Trueで上側に区切り線が表示される。Falseで区切り線なし
ElseIf bg = 2 Then
myPopup.BeginGroup = False
Else
MsgBox "1または2を入力して下さい！"
GoTo bgrr
End If
Case 3
ctsw:
On Error GoTo ErrorHandler
cts = Application.InputBox(Prompt:="サブメニュー名を入力して下さい", Type:=2)
If TypeName(cts) = "Boolean" Then
Exit Sub
ElseIf cts = "" Then
GoTo ctsw
End If
ctw:
ct = Application.InputBox(Prompt:="サブメニューの上位階層のメニュー名を入力して下さい", Type:=2)
If TypeName(ct) = "Boolean" Then
Exit Sub
ElseIf ct = "" Then
GoTo ctw
End If
oaw:
oa = Application.InputBox(Prompt:="サブメニューに登録するマクロ名を入力して下さい", Type:=2)
If TypeName(oa) = "Boolean" Then
Exit Sub
ElseIf oa = "" Then
GoTo oaw
End If
bfw:
bf = Application.InputBox(Prompt:="サブメニューを上から何番目に配置しますか？（0で末尾）", Type:=1)
If TypeName(bf) = "Boolean" Then
Exit Sub
ElseIf bf = 0 Then
Set myButton = CommandBars("Cell").Controls(ct).Controls.Add
ElseIf bf >= 1 And bf <= CommandBars("Cell").Controls(ct).Controls.Count Then
Set myButton = CommandBars("Cell").Controls(ct).Controls.Add(Before:=bf) 'Before:=で配置位置を指定する。省略で末尾に配置
Else
MsgBox "0～" & CommandBars("Cell").Controls(ct).Controls.Count & "の数値で入力して下さい"
GoTo bfw
End If
myButton.Caption = cts '追加するサブメニュー名を入力
myButton.OnAction = oa '実行するマクロ名を入力
bgw:
bg = Application.InputBox(Prompt:="サブメニューの上側に区切り線を入れますか？" & vbCrLf & _
"1:入れる" & vbCrLf & "2:入れない", Type:=1)
If TypeName(bg) = "Boolean" Then
Exit Sub
ElseIf bg = 1 Then
myButton.BeginGroup = True 'Trueで上側に区切り線が表示される。Falseで区切り線なし
ElseIf bg = 2 Then
myButton.BeginGroup = False
Else
MsgBox "1または2を入力して下さい！"
GoTo bgw
End If
Case 4
ctx:
On Error GoTo ErrorHandler
ct = Application.InputBox(Prompt:="削除するメニュー名を入力して下さい", Type:=2)
If TypeName(ct) = "Boolean" Then
Exit Sub
ElseIf ct = "" Then
GoTo ctx
End If
CommandBars("Cell").Controls(ct).Delete '削除するメニュー名を入力
Case 5
ctsx:
On Error GoTo ErrorHandler
cts = Application.InputBox(Prompt:="削除するサブメニュー名を入力して下さい", Type:=2)
If TypeName(cts) = "Boolean" Then
Exit Sub
ElseIf cts = "" Then
GoTo ctsx
End If
ctsz:
ct = Application.InputBox(Prompt:="サブメニューの上位階層のメニュー名を入力して下さい", Type:=2)
If TypeName(ct) = "Boolean" Then
Exit Sub
ElseIf ct = "" Then
GoTo ctsz
End If
CommandBars("Cell").Controls(ct).Controls(cts).Delete '削除するサブメニュー名を入力
Case 6
CommandBars("Cell").Reset
End Select
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 5
MsgBox "入力された名称が間違っているか、存在しません"
End Select
End Sub
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。
右クリックした際の第一階層メニューには隠しメニューなどがあるので、追加するメニューを配置する正確な順番を知りたい場合は下記の記事のマクロを使用下さい。
