vvf
‘////////////////////////// ‘/ ‘/ 『ＦａｃｅＩｄ一覧の表示』 ‘/ このマクロは「エクセルファンクラブ』 ‘/ ＶＢＡラウンジで回答したものです ‘/ 自由にコピーして各自のマクロにコピー ‘/ しても構いません （角田） ‘/ ‘/ 2001/10/9 コマンドバーの『閉じるボタン(X)』を ‘/ 無効(非表示)にするプロパティを追加 ‘/ ‘//////////////////////////
Public strRow As String
Private Const cstBarName As String = “FaceId一覧” Private int表示位置 As Integer
Public Sub FaceId表示() int表示位置 = 1 Call FaceId一覧表示 End Sub
Private Sub FaceId表示Previous() Dim MyCB As CommandBar On Error Resume Next ‘ボタンクリック時に呼ばれるからコマンドバーは必ず存在する Set MyCB = Application.CommandBars(cstBarName) int表示位置 = Val(MyCB.Controls(2).Caption) ‘[～]の前のみ Set MyCB = Nothing
If (int表示位置 > 1) Then
int表示位置 = int表示位置 - 500
Call FaceId一覧表示
End If
End Sub
Private Sub FaceId表示Next() Dim MyCB As CommandBar On Error Resume Next ‘ボタンクリック時に呼ばれるからコマンドバーは必ず存在する Set MyCB = Application.CommandBars(cstBarName) int表示位置 = Val(MyCB.Controls(2).Caption) ‘[～]の前のみ Set MyCB = Nothing
If (int表示位置 < 4001) Then
int表示位置 = int表示位置 + 500
Call FaceId一覧表示
End If
End Sub
Private Sub FaceId一覧表示() Dim i As Integer Dim j As Integer Dim MyCB As CommandBar Dim MyCBCtrl As CommandBarControl ‘——————-コマンドバー作成(Temporary)——————- On Error Resume Next Set MyCB = Application.CommandBars(cstBarName) On Error GoTo 0 If (MyCB Is Nothing) Then ‘——————- 初回表示 ——————————————- Set MyCB = Application.CommandBars.Add(cstBarName, , , True) ’ コマンドバーの「閉じるボタン(X)」を無効(非表示)にする MyCB.Protection = msoBarNoChangeVisible ‘Controls(1) Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl .FaceId = 132 ’ (←) .TooltipText = “前の500個” .OnAction = “FaceId表示Previous” End With ‘Controls(2) Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl .Style = msoButtonCaption .Caption = “1～500” End With ‘Controls(3) Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl .FaceId = 133 ’ (→) .TooltipText = “次の500個” .OnAction = “FaceId表示Next” End With ‘Controls(4) Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl .FaceId = 358 .TooltipText = “FaceId一覧の消去” .OnAction = “FaceId一覧削除” End With ‘Controls(5)～(504) For i = 1 To 500 Set MyCBCtrl = MyCB.Controls.Add(Type:=msoControlButton) With MyCBCtrl If (i = 1) Then .BeginGroup = True End If .FaceId = i .TooltipText = “(” & i & “)” End With Next i
With MyCB
.Width = MyCB.Controls(5).Width * 26 ' (25個分+α)
.Top = 50
.Left = 50
.Visible = True
End With
‘——————- 表示範囲の書き換え ————————————— Else With MyCB.Controls(2) ’ 表示範囲 .Caption = int表示位置 & “～” & int表示位置 + 499 End With
For i = 1 To 500
With MyCB.Controls(i + 4) '(5)～(504)
j = int表示位置 + i - 1
.FaceId = j
.TooltipText = "(" & j & ")"
End With
Next i
MyCB.Visible = True
End If
Set MyCBCtrl = Nothing
Set MyCB = Nothing
End Sub
Private Sub FaceId一覧削除() On Error Resume Next Application.CommandBars(cstBarName).Delete End Sub
Sub 同一Sheetの複数画面表示() ’ ’ Keyboard Shortcut: ’ Dim sBookName As String Dim nLen As Integer sBookName = ActiveWindow.Caption nLen = Len(sBookName) ActiveWindow.NewWindow If Mid(sBookName, nLen - 1, 1) <> “:” Then Windows(sBookName & “:1”).Activate End If Windows.Arrange ArrangeStyle:=xlHorizontal
End Sub
Sub すべてのシートをHOME_Positionへ()
Dim ws As Variant
For Each ws In Worksheets
If Sheets(ws.Name).Visible = True Then
Sheets(ws.Name).Select
Range("A1").Select
End If
Next
Sheets(1).Select
End Sub
Sub セル移動方向切替()
If Application.MoveAfterReturn = False Then
Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlDown
Exit Sub
End If
If Application.MoveAfterReturnDirection = xlDown Then
Application.MoveAfterReturnDirection = xlToRight
Else
Application.MoveAfterReturnDirection = xlDown
End If
End Sub
Sub 枠線表示切替え()
ActiveWindow.DisplayGridlines = Not (ActiveWindow.DisplayGridlines)
End Sub
Sub 行列番号表示切替()
ActiveWindow.DisplayHeadings = Not (ActiveWindow.DisplayHeadings)
End Sub
Sub 全シート表示()
Dim ws As Variant
For Each ws In Sheets
Sheets(ws.Name).Visible = True
Next
Sheets(1).Select
End Sub
Sub シート隠蔽()
Dim ws As Variant
Dim response As Integer
Dim i As Integer
Dim cnt As Integer
cnt = 0
For Each ws In Sheets
If Sheets(ws.Name).Visible = True Then '表示されているシートの数
cnt = cnt + 1
End If
Next
i = 0
For Each ws In Sheets
If Sheets(ws.Name).Visible = True Then
Sheets(ws.Name).Select
i = i + 1
response = MsgBox("シート(" & i & ") 【 " & ws.Name & " 】 を隠しますか？" & Chr$(13) & Chr$(13), _
vbYesNoCancel + vbQuestion + vbDefaultButton2, "確認！")
If response = vbYes Then
If cnt = 1 Then
MsgBox "全てのシートを非表示にする事は出来ません！", vbExclamation
Exit Sub
End If
Sheets(ws.Name).Visible = False
cnt = cnt - 1
Else
If response = vbCancel Then
Exit Sub
End If
End If
End If
Next
End Sub
Sub セル縦位置中央揃え() ’ ’ With Selection .VerticalAlignment = xlCenter End With End Sub
Sub A1_R1C1()
If Application.ReferenceStyle = xlR1C1 Then
Application.ReferenceStyle = xlA1
Else
Application.ReferenceStyle = xlR1C1
End If
End Sub
Sub Auto_Open() ’ Menu削除 1 ‘ここで起動時に（念のためいったん削除してから）メニューを追加（作成）します Menu追加 1 ‘既にauto_open() を記述している場合は、以下の２行を追加します。 Add_RightClickMenu_2 1
'INSERTに行の挿入をセット
Application.OnKey "{INSERT}", "AS_RowsInsert"
’ ‘Ctrl+B に、値のみ貼り付けをセット ’ Application.OnKey “^b”, “AS_PasteValue”
With Application.CommandBars("reviewing")
.Enabled = Not .Enabled
End With
‘auto_open に既に他のマクロが記述されている場合には､ ‘この１行だけを追加する ’ End Sub Sub AS_PasteValue()
'値のみ貼り付けコマンドを実行
Selection.PasteSpecial Paste:=xlValues
End Sub
Private Sub AS_RowsInsert() ‘行の挿入 Application.SendKeys “%ir”
End Sub
Sub SetDefault()
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Sheets("Sheet1").Activate
Cells.Select
Selection.ColumnWidth = 1.25
Selection.RowHeight = 12.5
Sheets("Sheet3").Select
Range("A1").Select
Sheets("Sheet2").Select
Range("A1").Select
Sheets("Sheet1").Select
Range("A1").Select
End Sub
Sub Add_RightClickMenu_2(num%) ‘標準メニューの下に追加 ‘auto_openに追加するのを忘れずに！
Dim cstBar As CommandBar
Dim i As Long
For i = 23 To 28 'Excel97の場合は 21 to 26 にして下さい
'Excel2003の場合は 29 to 34 にして下さい
Application.CommandBars(i).Reset
Set cstBar = CommandBars(i)
cstBar_sub_2 cstBar
Next
’ End Sub
Sub cstBar_sub_2(cstBar As CommandBar)
Dim i%
i = cstBar.Controls.Count + 1
With cstBar
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "値のみ貼り付け"
.Controls(i).OnAction = "AS_PasteValue"
.Controls(i).FaceId = 2062
End With
i = cstBar.Controls.Count + 1
With cstBar
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "セル縦位置中央揃え"
.Controls(i).OnAction = "セル縦位置中央揃え"
.Controls(i).FaceId = 2062
End With
i = i + 1
With cstBar
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "センタリング"
.Controls(i).OnAction = "センタリング"
.Controls(i).FaceId = 122
.Controls(i).BeginGroup = True
End With
i = i + 1
With cstBar
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "現在のシート名を取得"
.Controls(i).OnAction = "シート名取得"
.Controls(i).FaceId = 593
.Controls(i).BeginGroup = True
End With
i = i + 1
With cstBar
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "現在のシート名に設定"
.Controls(i).OnAction = "シート名設定"
.Controls(i).FaceId = 592
.Controls(i).BeginGroup = True
End With
’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ｱｸﾃｨﾌﾞｼｰﾄの複数画面表示” ’ .Controls(i).OnAction = “同一Sheetの複数画面表示” ’ .Controls(i).FaceId = 585 ’ .Controls(i).BeginGroup = True ’ ’ End With ‘
’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “全シートをHOMEポジションに” ’ .Controls(i).OnAction = “すべてのシートをHOME_Positionへ” ’ .Controls(i).FaceId = 1826 ’ .Controls(i).BeginGroup = True ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “入力後のセル移動方向の変更” ’ .Controls(i).OnAction = “セル移動方向切替” ’ .Controls(i).FaceId = 133 ’ End With ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “枠線の表示切替” ’ .Controls(i).OnAction = “枠線表示切替え” ’ .Controls(i).FaceId = 217 ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “行列番号の表示切替” ’ .Controls(i).OnAction = “行列番号表示切替” ’ .Controls(i).FaceId = 800 ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “A1形式R1C1形式の切替” ’ .Controls(i).OnAction = “A1_R1C1” ’ .Controls(i).FaceId = 503 ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ｼｰﾄを確認しながら非表示にする” ’ .Controls(i).OnAction = “シート隠蔽” ’ .Controls(i).FaceId = 1641 ’ End With ‘
’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “選択したセルの情報(&L)” ’ .Controls(i).OnAction = “CellsInformation” ’ .Controls(i).FaceId = 343 ’ .Controls(i).BeginGroup = True ’ End With ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ウィンドウの上下整列(&1)” ’ .Controls(i).OnAction = “ウィンドウの上下整列” ’ .Controls(i).FaceId = 298 ’ End With ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “最近使用したファイルの一覧に追加(&E)” ’ .Controls(i).OnAction = “Add_RecentFiles” ’ .Controls(i).FaceId = 462 ’ End With ” ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “全ての隠しｼｰﾄを表示する(&Q)” ’ .Controls(i).OnAction = “全シート表示” ’ .Controls(i).FaceId = 2587 ’ .Controls(i).BeginGroup = True ’ End With ’ ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ｾﾙ縦位置上詰め(&4)” ’ .Controls(i).OnAction = “セル縦位置上詰め” ’ .Controls(i).FaceId = 2061 ’ End With ’ ’ i = i + 1 ’ With cstBar ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “列幅で折り返し(&5)” ’ .Controls(i).OnAction = “列幅折り返し表示” ’ .Controls(i).FaceId = 119 ’ End With ‘
End Sub
Sub Reset_RightClickMenu() ‘右クリックメニューを初期化する場合はこのマクロを実行 2003/10/26 ’ Dim i As Long
For i = 23 To 28
Application.CommandBars(i).Reset
Next
’ End Sub
Sub auto_close()
Menu削除 1 'エクセル終了時にメニューを削除します
End Sub
Sub Menu追加(num%) ‘ダミーの引数(num%)を付けているのは、「ツール」「マクロ」から指定できないようにするため
’ Faceid （アイコン） を調べたい時は「FaceId一覧表示」を使う Dim myBar As CommandBar Dim myCtrl As CommandBarControl Dim i% ’ Application.CommandBars(“Worksheet Menu Bar”).Reset ‘20010224 Menu削除 1 ‘20021021 Set myBar = CommandBars(“Worksheet Menu Bar”) Set myCtrl = myBar.Controls.Add(Type:=msoControlPopup, Temporary:=True) With myCtrl ”最初にココで、メニューバーに追加するメニュー名を指定する。 .Move Before:=9 .Caption = “MyTools(&X)” ‘(&英数字)はアクセスキーの指定（なくてもOK） .Visible = True
’ i = i + 1 ’ ’ .Controls.Add Type:=msoControlButton ’ .Controls(i).Caption = “ｳｨﾝﾄﾞｳの上下整列(&1)” ‘メニュー名の後ろに(&英数字)と記述すると、アクセスキーの指定になる（なくてもOK） ’ .Controls(i).OnAction = “ウィンドウの上下整列” ’ .Controls(i).FaceId = 298 ’ .Controls(i).BeginGroup = True ‘これを指定すると、メニューをセパレートする横棒が入る ’ i = i + 1 .Controls.Add Type:=msoControlButton .Controls(i).Caption = “セル縦位置中央揃え” .Controls(i).OnAction = “セル縦位置中央揃え” .Controls(i).FaceId = 2062 .Controls(i).BeginGroup = True
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "全シートをHomePositionに"
.Controls(i).OnAction = "すべてのシートをHOME_Positionへ"
.Controls(i).FaceId = 1826
.Controls(i).BeginGroup = True
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "シート順ソート"
.Controls(i).OnAction = "シート並び替え"
.Controls(i).FaceId = 654
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "入力後のセル移動方向の変更"
.Controls(i).OnAction = "セル移動方向切替"
.Controls(i).FaceId = 133
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "枠線の表示切替"
.Controls(i).OnAction = "枠線表示切替え"
.Controls(i).FaceId = 217
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "行列番号の表示切替"
.Controls(i).OnAction = "行列番号表示切替"
.Controls(i).FaceId = 800
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "A1形式R1C1形式の切替"
.Controls(i).OnAction = "A1_R1C1"
.Controls(i).FaceId = 503
.Controls(i).BeginGroup = True
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "ActiveSheetの複数画面表示"
.Controls(i).OnAction = "同一Sheetの複数画面表示"
.Controls(i).FaceId = 585
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "全ての隠しシートを表示する"
.Controls(i).OnAction = "全シート表示"
.Controls(i).FaceId = 2587
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "シートを確認しながら非表示にする"
.Controls(i).OnAction = "シート隠蔽"
.Controls(i).FaceId = 1641
i = i + 1
.Controls.Add Type:=msoControlButton
.Controls(i).Caption = "シート初期化"
.Controls(i).OnAction = "setdefault"
.Controls(i).FaceId = 800
End With
End Sub
Sub Menu削除(num%)
Dim myBar As CommandBar
Set myBar = CommandBars("Worksheet Menu Bar")
On Error Resume Next
myBar.Controls("MyTools(&X)").Delete
On Error GoTo 0
End Sub Sub CAVSCOT()
Dim i As Integer Dim j As Integer Dim k As Integer i = 1 k = 0
Load UserForm1 UserForm1.Show UserForm1.SetDefaultTabOrder
If strRow = “” Or _ IsNull(strRow) = True Then Else
Cells.Select
Selection.Sort Key1:=Range(strRow & "1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortTextAsNumbers
Do Until IsEmpty(Range(strRow & i).Value)
j = i + 1
If Range(strRow & i) = Range(strRow & j) Then
Rows(j & ":" & j).Select
Selection.Delete Shift:=xlUp
Else
i = i + 1
End If
Loop
End If
Cavscot_Exit: ’ FRM_USERをｱﾝﾛｰﾄﾞしｵﾌﾞｼﾞｪｸﾄを解放 Unload UserForm1 Set UserForm1 = Nothing End Sub
Sub 指定した列のデータでシート分け() Dim workSh As Worksheet Dim tempSh As Worksheet Dim mRng As Range Dim sRng As Range, sR As Range Dim st$ Dim i As Long, j As Integer
Application.ScreenUpdating = False
Set workSh = ActiveSheet
Load UserForm1
UserForm1.Show
UserForm1.SetDefaultTabOrder
If strRow = "" Or _
IsNull(strRow) = True Then
Else
Cells.Select
Selection.Sort Key1:=Range(strRow & "1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortTextAsNumbers
With workSh
'データテーブル作成
Set mRng = .Range(strRow & "1").CurrentRegion
.Range("IV1") = .Range(strRow & "1").Value
.Range("IT1") = .Range(strRow & "1").Value
mRng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("IV1"), Unique:=False
'データ毎にシート作成、該当データ抽出
Set sRng = .Range("IV1").CurrentRegion
For i = 2 To sRng.Rows.Count
.Range("IT2") = sRng(i, 1)
Set sR = .Range("IT1").CurrentRegion
'シートの存在チェック
st = CStr(sR(2, 1)) '調べるシート名
If TypeName(Application.Evaluate(st & "!A1")) = "Range" Then
'シートがある時は中身をクリア
Worksheets(CStr(sR(2, 1))).Activate
Cells.Select
Cells.Delete
Else
With Worksheets.Add()
.Name = CStr(sR(2, 1))
End With
End If
Set tempSh = Worksheets(st)
mRng.AdvancedFilter xlFilterCopy, sR, tempSh.Range("A1"), False
tempSh.Range(strRow & "1").EntireRow.Delete xlUp
Next
sR.Clear
sRng.Clear
Set sRng = Nothing: Set mRng = Nothing
End With
Application.ScreenUpdating = True
End If
End Sub
Sub シート名設定()
If ActiveCell.Value = "" Or Null Then
Else
If Len(ActiveCell.Value) >= 31 Then
MsgBox "文字数が多すぎます！"
Else
If InStr(StrConv(ActiveCell.Value, 8), ":") > 0 Then
MsgBox "記号は入力できません！"
Exit Sub
End If
If InStr(StrConv(ActiveCell.Value, 8), "*") > 0 Then
MsgBox "記号は入力できません！"
Exit Sub
End If
If InStr(StrConv(ActiveCell.Value, 8), "/") > 0 Then
MsgBox "記号は入力できません！"
Exit Sub
End If
If InStr(StrConv(ActiveCell.Value, 8), "\") > 0 Then
MsgBox "記号は入力できません！"
Exit Sub
End If
If InStr(StrConv(ActiveCell.Value, 8), "?") > 0 Then
MsgBox "記号は入力できません！"
Exit Sub
End If
If InStr(StrConv(ActiveCell.Value, 8), "[") > 0 Then
MsgBox "記号は入力できません！"
Exit Sub
End If
If InStr(StrConv(ActiveCell.Value, 8), "]") > 0 Then
MsgBox "記号は入力できません！"
Exit Sub
End If
ActiveSheet.Name = ActiveCell.Value
End If
End If
End Sub
Sub シート名取得()
ActiveCell.Value = ActiveSheet.Name
End Sub
Sub シート結合() Dim シート数 As Integer Dim i As Integer Dim 最終行 As Long
Worksheets.Add Before:=Worksheets(1)
シート数 = Worksheets.Count For i = 2 To シート数 Worksheets(i).Range(“A2”).CurrentRegion.Copy 最終行 = Worksheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row Worksheets(1).Cells(最終行 + 2, 1).Select Worksheets(1).Paste Next
End Sub
Sub シート並び替え()
Dim intLoopA As Integer Dim intLoopB As Integer
For intLoopA = 1 To Sheets.Count For intLoopB = 1 To Sheets.Count - 1 If Sheets(intLoopB).Name > Sheets(intLoopB + 1).Name Then Sheets(intLoopB).Move after:=Sheets(intLoopB + 1) End If Next intLoopB Next intLoopA
End Sub
Sub 縮小して全体を表示() ’ ’ Keyboard Shortcut: Ctrl+shift+N ’ With Selection If .ShrinkToFit = True Then .ShrinkToFit = False Else .ShrinkToFit = True End If End With
End Sub
Sub センタリング() ’ ’ Keyboard Shortcut: Ctrl+Shift+C ’ With Selection
If .HorizontalAlignment = xlCenter Then
.HorizontalAlignment = xlLeft
Else
.HorizontalAlignment = xlCenter
End If
.VerticalAlignment = xlCenter
End With
End Sub
Sub セル結合() ’ ’ Keyboard Shortcut: Ctrl+Shift+K ’ With Selection
If .MergeCells = True Then
.UnMerge
Else
.MergeCells = True
End If
End With
End Sub
Sub インデント右() ’ ’ Keyboard Shortcut: ’ With Selection If .IndentLevel < 15 Then .IndentLevel = .IndentLevel + 1 End If End With End Sub
Sub インデント左() ’ ’ Keyboard Shortcut: ’ With Selection If .IndentLevel > 0 Then .IndentLevel = .IndentLevel - 1 End If End With End Sub
Sub 書式設定_日付() ’ ’ Keyboard Shortcut: Ctrl+t ’ Selection.NumberFormatLocal = “yyyy/mm/dd” End Sub
Sub 周りに罫線() ’ ’ Keyboard Shortcut: Ctrl+Shift+y ‘
If Selection.Borders(xlEdgeTop).LineStyle = xlNone Then
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Else
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End If
End Sub
Sub 複数ブックまとめる() Dim NewBook As Workbook Dim FileNames As Variant Dim CurIndex As Integer FileNames = Application.GetOpenFilename(FileFilter:=”EXCELファイル(*.xls), *.xls”, MultiSelect:=True) If TypeName(FileNames) = “Boolean” Then Exit Sub For CurIndex = 1 To UBound(FileNames) Workbooks.Open FileNames(CurIndex) With ActiveWorkbook If NewBook Is Nothing Then .Worksheets(1).Copy Set NewBook = ActiveWorkbook Else .Worksheets(1).Copy after:=NewBook.Worksheets(NewBook.Worksheets.Count) End If .Close End With With NewBook .Worksheets(.Worksheets.Count).Name = Left(Dir(FileNames(CurIndex)), Len(Dir(FileNames(CurIndex))) - 4) End With Next End Sub
Sub ExChgCode() Selection.Replace What:=”” & Chr(10) & “”, Replacement:=”” & Chr(11) & “” End Sub
