目安箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
107 / 107 ツリー ←次へ

【4】アドインファイルにてツールバーを表示するには、[ソフト紹介] ぴかる 02/9/2(月) 20:42 Excel[未読]

【15】各種マクロ ぴかる 02/9/2(月) 21:21 Excel[未読]

【15】各種マクロ
Excel  ぴかる  - 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 'これを有効にすると全て表示となるけど2回押さないとダメみたい
                    '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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
107 / 107 ツリー ←次へ
ページ:  ┃  記事番号:   
0
(SS)C-BOARD v3.8 is Free