管理人の覚書 <拡張機能.bas >

RC切替 †

Sub RC切替_tools(control As IRibbonControl)
    If Application.ReferenceStyle = xlA1 Then
         Application.ReferenceStyle = xlR1C1
    Else
         Application.ReferenceStyle = xlA1
    End If
End Sub

Win最大 †

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

半角2全角 †

Sub 半角2全角_tools(control As IRibbonControl)
    For Each cellval In Selection
        cellval.Value = StrConv(cellval, vbWide)
    Next
End Sub

全角2半角 †

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

セル2コメント †

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

コメント2セル †

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

UNIQ †

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