目安箱 IV

目安箱投稿のルールはこちらをごらんください。
ご意見は電子メールで承っています。
「目安箱」は質問禁止です。技術的な質問はそれぞれの質問箱へどうぞ。

迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

┃ ┃ ┃ ┃ ┃ ┃

263 / 277

←次へ　｜　前へ→

【15】各種マクロ

ぴかる - 02/9/2(月) 21:21 -


	引用なし

	パスワード

Sub 表示形式()
　　
　　If (ActiveSheet.ProtectContents) Or (TypeName(Selection) <> "Range") Then
　　エラーメッセージ
　　Else
　　 Application.Dialogs(xlDialogFormatNumber).Show
　　End If

End Sub
Sub 配置()
　　
　　If (ActiveSheet.ProtectContents) Or (TypeName(Selection) <> "Range") Then
　　エラーメッセージ
　　Else
　　 Application.Dialogs(xlDialogAlignment).Show
　　End If

End Sub
Sub フォント()

　　If (ActiveSheet.ProtectContents) Or (TypeName(Selection) <> "Range") Then
　　エラーメッセージ
　　Else
　　 Application.Dialogs(xlDialogFont).Show
　　End If

End Sub
Sub 罫線()
　　
　　If (ActiveSheet.ProtectContents) Or (TypeName(Selection) <> "Range") Then
　　エラーメッセージ
　　Else
　　 Application.Dialogs(xlDialogBorder).Show
　　End If
　　
End Sub
Sub パターン()
　　
　　If (ActiveSheet.ProtectContents) Or (TypeName(Selection) <> "Range") Then
　　エラーメッセージ
　　Else
　　 Application.Dialogs(xlDialogPatterns).Show
　　End If

End Sub
Sub 保護()
　　
　　If (ActiveSheet.ProtectContents) Or (TypeName(Selection) <> "Range") Then
　　エラーメッセージ
　　Else
　　 Application.Dialogs(xlDialogCellProtection).Show
　　End If

End Sub
Sub シート保護()

　　If ActiveSheet.ProtectContents Then
　　 ActiveSheet.Unprotect
　　Else
　　 ActiveSheet.Protect
　　End If

End Sub
Sub シート選択()

　　CommandBars("WorkBook tabs").ShowPopup

End Sub
Sub シート見出し()
　　
　　If ActiveWindow.DisplayWorkbookTabs = False Then
　　　ActiveWindow.DisplayWorkbookTabs = True
　　ElseIf ActiveWindow.DisplayWorkbookTabs = True Then
　　　ActiveWindow.DisplayWorkbookTabs = False
　　End If
　　
End Sub
Sub 全てクリア()
　
If ActiveSheet.ProtectContents Then
Else
　
　 Selection.Clear

　 Dim Sh As Shape, R1 As Range, R2 As Range
　 If TypeName(Selection) = "Range" Then
　　　If ActiveSheet.Shapes.Count > 0 Then
　　　　 For Each Sh In ActiveSheet.Shapes
　　　　　　'図形が完全に範囲に含まれる場合は削除する
　　　　　　'図形左上セルのチェック
　　　　　　Set R1 = Application.Intersect(Selection, _
　　　　　　　　　　　　　　　　　　　　　 Sh.TopLeftCell)
　　　　　 '図形右下セルのチェック
　　　　　 Set R2 = Application.Intersect(Selection, _
　　　　　　　　　　　　　　　　　　　　　 Sh.BottomRightCell)
　　　　　　If R1 Is Nothing Or R2 Is Nothing Then
　　　　　　　'左上セルまたは右下セルが選択範囲の外にある場合は無視
　　　　　　　 '両方外にある場合も無視
　　　　　 Else
　　　　　　　Sh.Delete
　　　　　　End If
　　　　 Next
　　　End If
　 End If
　
　 Set R1 = Nothing: Set R2 = Nothing
　　
　End If

End Sub
Sub 書式と値の貼り付け()
　
　 On Error GoTo errout
　 With Selection
　　　.PasteSpecial Paste:=xlPasteValues
　　　.PasteSpecial Paste:=xlPasteFormats
　 End With
finish:
　 Exit Sub
errout:
　 MsgBox Error(Err.Number), vbCritical
　 Resume finish

End Sub
Sub 列Caption()
　　
　　Set myCBCtrl = Application.CommandBars("PikaBar").Controls("セル書式").Controls(8)
　　If Application.ReferenceStyle = xlR1C1 Then
　　 myCBCtrl.Caption = "列表示…A1形式"
　　ElseIf Application.ReferenceStyle = xlA1 Then
　　 myCBCtrl.Caption = "列表示…R1C1形式"
　　End If
　　
　　'CommandBars.AdaptiveMenus = False　'これを有効にすると全て表示となるけど２回押さないとダメみたい
　　　　　　　　　　　　　　　　　　　　'2000以上有効
End Sub
Sub 列表示切替()
　　
　　If Application.ReferenceStyle = xlR1C1 Then
　　　Application.ReferenceStyle = xlA1
　　ElseIf Application.ReferenceStyle = xlA1 Then
　　　Application.ReferenceStyle = xlR1C1
　　End If

End Sub
Sub エラーメッセージ()
　　
　　 MsgBox "実行できましぇん！。" & vbLf & _
　　　　　　"（セル以外を選択？　シート保護中？）"

End Sub

6,016 hits