Attribute VB_Name = "拡張機能" Sub RC切替_tools(control As IRibbonControl) If Application.ReferenceStyle = xlA1 Then Application.ReferenceStyle = xlR1C1 Else Application.ReferenceStyle = xlA1 End If End Sub Sub Win最大_tools(control As IRibbonControl) Application.WindowState = xlNormal Application.Left = 1 Application.Top = 1 Application.Width = 1920 Application.Height = 745 End Sub Sub フィルタ解除_tools(control As IRibbonControl) If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData End If End Sub Sub 結合解除_tools(control As IRibbonControl) If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData End If 開始Y = Selection(1).Row 開始X = Selection(1).Column 終了Y = Selection(Selection.Count).Row 終了X = Selection(Selection.Count).Column For y = 開始Y To 終了Y For x = 開始X To 終了X Set セル = ActiveSheet.Cells(y, x) カウントX = セル.MergeArea.Columns.Count カウントY = セル.MergeArea.Rows.Count If カウントX > 1 Or カウントY > 1 Then セル.UnMerge For yy = 0 To カウントY - 1 For XX = 0 To カウントX - 1 セル.Offset(yy, XX) = セル Next Next End If Next Next End Sub Sub 自動計算停止_tools(control As IRibbonControl) Application.Calculation = xlManual Application.CalculateBeforeSave = False End Sub Sub 指定範囲再計算_tools(control As IRibbonControl) Selection.Calculate End Sub Sub 格子に並べて表示_tools(control As IRibbonControl) Windows.Arrange xlArrangeStyleTiled End Sub Sub 横に並べて表示_tools(control As IRibbonControl) Windows.Arrange xlArrangeStyleVertical End Sub Sub 縦に並べて表示_tools(control As IRibbonControl) Windows.Arrange xlArrangeStyleHorizontal End Sub Sub 範囲で中央_tools(control As IRibbonControl) 開始Y = Selection(1).Row 開始X = Selection(1).Column 終了Y = Selection(Selection.Count).Row 終了X = Selection(Selection.Count).Column Range(Cells(開始Y, 開始X), Cells(終了Y, 終了X)).HorizontalAlignment = xlCenterAcrossSelection End Sub Sub 半角2全角_tools(control As IRibbonControl) For Each cellval In Selection cellval.Value = StrConv(cellval, vbWide) Next End Sub Sub 全角2半角_tools(control As IRibbonControl) For Each cellval In Selection cellval.Value = StrConv(cellval, vbNarrow) Next End Sub Sub 空白削除_tools(control As IRibbonControl) For Each cellval In Selection cellval.Value = Trim(cellval) Next End Sub Sub 大文字変換_tools(control As IRibbonControl) For Each cellval In Selection cellval.Value = StrConv(cellval, vbUpperCase) Next End Sub Sub 小文字変換_tools(control As IRibbonControl) For Each cellval In Selection cellval.Value = StrConv(cellval, vbLowerCase) Next End Sub Sub セル2コメント_tools(control As IRibbonControl) 開始Y = Selection(1).Row 開始X = Selection(1).Column 終了Y = Selection(Selection.Count).Row 終了X = Selection(Selection.Count).Column For x = 開始X To 終了X For y = 開始Y To 終了Y If Cells(y, x) = "" Then Else Cells(y, x).ClearComments Cells(y, x).AddComment CStr(Cells(y, x)) Cells(y, x) = "" End If Next Next End Sub Sub コメント2セル_tools(control As IRibbonControl) 開始Y = Selection(1).Row 開始X = Selection(1).Column 終了Y = Selection(Selection.Count).Row 終了X = Selection(Selection.Count).Column For x = 開始X To 終了X For y = 開始Y To 終了Y If Cells(y, x).Comment Is Nothing Then Else Cells(y, x) = Cells(y, x).Comment.Text Cells(y, x).ClearComments End If Next Next End Sub Sub UNIQ_tools(control As IRibbonControl) Dim CB As New DataObject Set objNamedArrayKey = CreateObject("Scripting.Dictionary") For i = 1 To Selection.Count データ = Trim(Selection(i)) If データ <> "" And objNamedArrayKey.exists(データ) = False Then objNamedArrayKey.Add データ, データ 結果 = 結果 & データ & vbLf End If Next CB.SetText Trim(結果) CB.PutInClipboard End Sub Sub スタイル削除_tools(control As IRibbonControl) On Error Resume Next Set WB = Workbooks(ActiveWorkbook.Name) For Each ST In WB.Styles If InStr("Normal,Followed Hyperlink,Percent,Comma [0],Currency [0]", ST.Name) = 0 Then Debug.Print ST.Name WB.Styles(ST.Name).Delete End If Next End Sub Sub 名前定義削除_tools(control As IRibbonControl) On Error Resume Next Set WB = Workbooks(ActiveWorkbook.Name) For Each 名前 In WB.Names Debug.Print 名前.Name WB.Names(名前.Name).Delete Next End Sub Sub 日付変換_tools(control As IRibbonControl) For Each cellval In Selection If IsDate(cellval.Value) Then cellval.Value = "'" & cellval End If Next End Sub Sub フィルタ_tools(control As IRibbonControl) On Error Resume Next Dim CB As New DataObject 行 = ActiveCell.Row 列 = ActiveCell.Column 範囲 = Selection.Count If 範囲 > 1 Then CB.GetFromClipboard キー = Trim(Replace(CB.GetText, vbCrLf, "")) Else キー = Cells(行, 列) End If Selection.AutoFilter field:=列, Criteria1:="*" & キー & "*" End Sub