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

http://snri.net/wiki/index.php?%E6%8B%A1%E5%BC%B5%E6%A9%9F%E8%83%BD.bas

[ トップ ]   [ 編集 | 差分 | バックアップ | 添付 | リロード ]   [ 新規 | 一覧 | 単語検索 | 最終更新 | ヘルプ ]

• 追加された行はこの色です。
• 削除された行はこの色です。
• 拡張機能.bas へ行く。
• 拡張機能.bas の差分を削除

---

#author("2018-01-28T11:44:17+09:00","","")
#author("2018-01-28T12:37:11+09:00","","")
#norelated
#contents
----
**RC切替 [#x1e34750]
**RC切替 [#b6726b7b]
 Sub RC切替_tools(control As IRibbonControl)
     If Application.ReferenceStyle = xlA1 Then
          Application.ReferenceStyle = xlR1C1
     Else
          Application.ReferenceStyle = xlA1
     End If
 End Sub

**Win最大 [#q5df4225]
**Win最大 [#a423942e]
 Sub Win最大_tools(control As IRibbonControl)
     Application.WindowState = xlNormal
     Application.Left = 1
     Application.Top = 1
     Application.Width = 1920
     Application.Height = 745
 End Sub

**フィルタ解除 [#td9c3414]
**フィルタ解除 [#i62d3b76]
 Sub フィルタ解除_tools(control As IRibbonControl)
     If ActiveSheet.FilterMode = True Then
         ActiveSheet.ShowAllData
     End If
 End Sub

**フィルタ [#h56ba433]
 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

**結合解除 [#g139eecd]
**結合解除 [#p9ff8c43]
 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

**自動計算停止 [#ac75222b]
 Sub 自動計算停止_tools(control As IRibbonControl)
     Application.Calculation = xlManual
     Application.CalculateBeforeSave = False
 End Sub

**指定範囲再計算 [#s8dbab48]
 Sub 指定範囲再計算_tools(control As IRibbonControl)
     Selection.Calculate
 End Sub

**格子に並べて表示 [#ebfc0574]
 Sub 格子に並べて表示_tools(control As IRibbonControl)
     Windows.Arrange xlArrangeStyleTiled
 End Sub

**横に並べて表示 [#zbd3af6b]
 Sub 横に並べて表示_tools(control As IRibbonControl)
     Windows.Arrange xlArrangeStyleVertical
 End Sub

**縦に並べて表示 [#ke5fa83a]
 Sub 縦に並べて表示_tools(control As IRibbonControl)
     Windows.Arrange xlArrangeStyleHorizontal
 End Sub

**範囲で中央 [#pf01090c]
 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全角 [#vdbd9259]
 Sub 半角2全角_tools(control As IRibbonControl)
     For Each cellval In Selection
         cellval.Value = StrConv(cellval, vbWide)
     Next
 End Sub

**全角2半角 [#xdea6fef]
 Sub 全角2半角_tools(control As IRibbonControl)
     For Each cellval In Selection
         cellval.Value = StrConv(cellval, vbNarrow)
     Next
 End Sub

**空白削除 [#o1607f1d]
 Sub 空白削除_tools(control As IRibbonControl)
     For Each cellval In Selection
         cellval.Value = Trim(cellval)
     Next
 End Sub

**大文字変換 [#v22dc2ea]
 Sub 大文字変換_tools(control As IRibbonControl)
     For Each cellval In Selection
         cellval.Value = StrConv(cellval, vbUpperCase)
     Next
 End Sub

**小文字変換 [#m8541c80]
 Sub 小文字変換_tools(control As IRibbonControl)
     For Each cellval In Selection
         cellval.Value = StrConv(cellval, vbLowerCase)
     Next
 End Sub

**セル2コメント [#z4936118]
 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セル [#y0006315]
 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 [#s226bb08]
 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

**スタイル削除 [#p56fe07e]
 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

**名前定義削除 [#p63b69de]
 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

**日付変換 [#h42e5d10]
 Sub 日付変換_tools(control As IRibbonControl)
     For Each cellval In Selection
         If IsDate(cellval.Value) Then
             cellval.Value = "'" & cellval
         End If
     Next
 End Sub

**フィルタ [#c268eb63]
 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

       

Site admin: S.N.R.I.

PukiWiki 1.5.1 © 2001-2016 PukiWiki Development Team. Powered by PHP 7.4.33. HTML convert time: 0.004 sec.