ブック
シート名編集
シート名編集
Sub ブック_シート名編集()
'「INDEX」シートのD列から、シート名を編集します。
Dim s As Worksheet Dim r_end As Integer Dim i As Integer
On Error Resume Next Sheets("INDEX").Select If Err.Number <> 0 Then MsgBox "「INDEX」シートを作成してください。" Exit Sub End If On Error GoTo 0
Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With For i = 1 To r_end If s.Cells(i, 3).Value <> "" And s.Cells(i, 3).Value <> "非表示" Then Sheets(s.Cells(i, 1).Value).name = s.Cells(i, 3).Value ElseIf s.Cells(i, 4).Value <> "" Then Sheets(s.Cells(i, 1).Value).name = s.Cells(i, 4).Value End If Next i
End Sub
'「INDEX」シートのD列から、シート名を編集します。
Dim s As Worksheet Dim r_end As Integer Dim i As Integer
On Error Resume Next Sheets("INDEX").Select If Err.Number <> 0 Then MsgBox "「INDEX」シートを作成してください。" Exit Sub End If On Error GoTo 0
Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With For i = 1 To r_end If s.Cells(i, 3).Value <> "" And s.Cells(i, 3).Value <> "非表示" Then Sheets(s.Cells(i, 1).Value).name = s.Cells(i, 3).Value ElseIf s.Cells(i, 4).Value <> "" Then Sheets(s.Cells(i, 1).Value).name = s.Cells(i, 4).Value End If Next i
End Sub
シート表示
シート表示
Sub ブック_シート表示() Dim w_sheet As Worksheet For Each w_sheet In ActiveWorkbook.Sheets w_sheet.Visible = True Next w_sheet End Sub
INDEXリンク
INDEXリンク
Sub ブック_INDEXリンク作成() Range("A1").Select ActiveCell.FormulaR1C1 = "※" ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="INDEX!A1", TextToDisplay:="※" If Selection.Interior.Pattern <> xlNone Then '無 With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End If
If Range("A2").Value = "(LINK)" Then Range("A2").Value = "" End If If Range("B1") = "" Then Range("B1") = ActiveSheet.name End If
ActiveSheet.Range("A1").HorizontalAlignment = xlGeneral ActiveSheet.Columns(1).AutoFit ActiveSheet.Rows("3:3").Select ActiveWindow.FreezePanes = False ActiveWindow.FreezePanes = True ActiveSheet.Range("A1").Select End Sub
If Range("A2").Value = "(LINK)" Then Range("A2").Value = "" End If If Range("B1") = "" Then Range("B1") = ActiveSheet.name End If
ActiveSheet.Range("A1").HorizontalAlignment = xlGeneral ActiveSheet.Columns(1).AutoFit ActiveSheet.Rows("3:3").Select ActiveWindow.FreezePanes = False ActiveWindow.FreezePanes = True ActiveSheet.Range("A1").Select End Sub
ウインドウ枠の固定2行目
ウインドウ枠の固定2行目
Sub ブック_ウインドウ枠の固定2行目()
Application.EnableEvents = False For Each w_sheet In Sheets Application.StatusBar = "ハイパーリンク作成 " & i & "/" & Sheets.Count If w_sheet.Visible = xlSheetVisible Then If w_sheet.name <> "INDEX" Then w_sheet.Activate If w_sheet.Range("A1") = "" Or w_sheet.Range("A1") = "※" Or w_sheet.Range("A1") = "INDEX" Then ActiveWindow.FreezePanes = False w_sheet.Rows("1:1").Select w_sheet.Rows("3:3").Select ActiveWindow.FreezePanes = True w_sheet.Range("A1").Select End If Sheets("INDEX").Activate End If End If i = i + 1 Next w_sheet Application.EnableEvents = True
End Sub
Application.EnableEvents = False For Each w_sheet In Sheets Application.StatusBar = "ハイパーリンク作成 " & i & "/" & Sheets.Count If w_sheet.Visible = xlSheetVisible Then If w_sheet.name <> "INDEX" Then w_sheet.Activate If w_sheet.Range("A1") = "" Or w_sheet.Range("A1") = "※" Or w_sheet.Range("A1") = "INDEX" Then ActiveWindow.FreezePanes = False w_sheet.Rows("1:1").Select w_sheet.Rows("3:3").Select ActiveWindow.FreezePanes = True w_sheet.Range("A1").Select End If Sheets("INDEX").Activate End If End If i = i + 1 Next w_sheet Application.EnableEvents = True
End Sub
シート並び替え
シート並び替え
Sub ブック_シート並び替え()
Dim w_sheet As Worksheet Dim s As Worksheet Dim i As Integer Dim r_end As Integer
On Error Resume Next Worksheets("INDEX").Select If Err.Number <> 0 Then MsgBox ("「INDEX」シートがありません。") Exit Sub End If On Error GoTo 0
Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With
On Error Resume Next For i = 1 To r_end Sheets(s.Cells(i, 2).Value).Move After:=Sheets(Sheets.Count) s.Cells(i, 1).Value = i If Err.Number <> 0 Then s.Select s.Cells(i, 2).Select MsgBox ("「INDEX」シートが最新ではありません。") Exit Sub End If Next i On Error GoTo 0 If Sheets.Count <> r_end Then MsgBox ("「INDEX」シートが最新ではありません。") End If
Sheets(1).Activate
End Sub
Dim w_sheet As Worksheet Dim s As Worksheet Dim i As Integer Dim r_end As Integer
On Error Resume Next Worksheets("INDEX").Select If Err.Number <> 0 Then MsgBox ("「INDEX」シートがありません。") Exit Sub End If On Error GoTo 0
Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With
On Error Resume Next For i = 1 To r_end Sheets(s.Cells(i, 2).Value).Move After:=Sheets(Sheets.Count) s.Cells(i, 1).Value = i If Err.Number <> 0 Then s.Select s.Cells(i, 2).Select MsgBox ("「INDEX」シートが最新ではありません。") Exit Sub End If Next i On Error GoTo 0 If Sheets.Count <> r_end Then MsgBox ("「INDEX」シートが最新ではありません。") End If
Sheets(1).Activate
End Sub
名前全表示
名前全表示
Sub ブック_名前全表示()
Dim name As Object
For Each name In Names If name.Visible = False Then name.Visible = True End If Next
MsgBox "すべての名前の定義を表示しました。", vbOKOnly
End Sub
Dim name As Object
For Each name In Names If name.Visible = False Then name.Visible = True End If Next
MsgBox "すべての名前の定義を表示しました。", vbOKOnly
End Sub
見出し
見出し
Sub ブック_見出し()
'選択範囲から、見出しシートを作成
Dim s As Worksheet Dim s0 As Worksheet
Dim w_cell As Range Dim w_selection As Range
Dim x As Integer Dim row_bk As Integer
Application.DisplayAlerts = False Set s0 = ActiveSheet Set w_selection = Selection On Error Resume Next Sheets("見出し").Delete On Error GoTo 0 Sheets.Add before:=Sheets(1) Set s = ActiveSheet s.Name = "見出し"
x = 0 row_bk = 0 For Each w_cell In w_selection.Cells If w_cell.Value <> "" Then If row_bk <> w_cell.Row Then x = x + 1 End If s.Cells(x, w_cell.Column).Value = w_cell.Value ActiveSheet.Hyperlinks.Add Anchor:=s.Cells(x, w_cell.Column), Address:="", SubAddress:="'" & s0.Name & "'!" & w_cell.Address, _ TextToDisplay:="'" & s.Cells(x, w_cell.Column).Value row_bk = w_cell.Row End If Next w_cell
s.Cells.EntireColumn.AutoFit s.Columns(1).ColumnWidth = 2
Application.DisplayAlerts = True
End Sub
'選択範囲から、見出しシートを作成
Dim s As Worksheet Dim s0 As Worksheet
Dim w_cell As Range Dim w_selection As Range
Dim x As Integer Dim row_bk As Integer
Application.DisplayAlerts = False Set s0 = ActiveSheet Set w_selection = Selection On Error Resume Next Sheets("見出し").Delete On Error GoTo 0 Sheets.Add before:=Sheets(1) Set s = ActiveSheet s.Name = "見出し"
x = 0 row_bk = 0 For Each w_cell In w_selection.Cells If w_cell.Value <> "" Then If row_bk <> w_cell.Row Then x = x + 1 End If s.Cells(x, w_cell.Column).Value = w_cell.Value ActiveSheet.Hyperlinks.Add Anchor:=s.Cells(x, w_cell.Column), Address:="", SubAddress:="'" & s0.Name & "'!" & w_cell.Address, _ TextToDisplay:="'" & s.Cells(x, w_cell.Column).Value row_bk = w_cell.Row End If Next w_cell
s.Cells.EntireColumn.AutoFit s.Columns(1).ColumnWidth = 2
Application.DisplayAlerts = True
End Sub
INDEX
INDEX
Sub ブック_INDEX() 'シートのINDEXを作成する。 Dim s As Worksheet Dim i As Integer Dim w_sheet As Worksheet Dim w_rtn As Integer ' w_rtn = MsgBox("一覧をシート名順に並べ替えますか？", vbYesNoCancel)' If w_rtn = vbCancel Then' Exit Sub' End If w_rtn = vbNo Application.DisplayAlerts = False On Error Resume Next Sheets("INDEX").Delete On Error GoTo 0 ' On Error Resume Next' For Each w_sheet In Sheets' If w_sheet.name <> "INDEX" Then' If Left(w_sheet.name, 1) = "F" Then' w_sheet.name = "W" & Mid(w_sheet.name, 2, 99)' ElseIf Left(w_sheet.name, 1) = "B" Then' w_sheet.name = "S" & Mid(w_sheet.name, 2, 99)' End If' End If' Next w_sheet' On Error GoTo 0 Sheets.Add before:=Sheets(1) Set s = ActiveSheet s.Name = "INDEX" s.Cells.ColumnWidth = 2 i = 1 Application.EnableEvents = False Application.ScreenUpdating = False For Each w_sheet In Sheets Application.StatusBar = "ハイパーリンク作成 " & i & "/" & Sheets.Count s.Cells(i, 1) = w_sheet.Index s.Cells(i, 2) = "'" & w_sheet.Name ActiveSheet.Hyperlinks.Add _ Anchor:=s.Cells(i, 2), Address:="", SubAddress:="'" & s.Cells(i, 2).Value & "'!A1", TextToDisplay:="'" & s.Cells(i, 2).Value If w_sheet.Visible = xlSheetHidden Then s.Cells(i, 2).Interior.ColorIndex = 15 s.Cells(i, 3).Value = "非表示" End If ' If w_sheet.Cells(1, 2) = "" Then' s.Cells(i, 3) = s.Cells(i, 2)' Else' If IsNumeric(w_sheet.Cells(1, 2)) Then' s.Cells(i, 3) = s.Cells(i, 2)' Else' s.Cells(i, 3) = w_sheet.Cells(1, 2)' End If' End If ' If w_sheet.Visible = xlSheetHidden Then' s.Cells(i, 4) = "非表示"' End If ' If w_sheet.Name <> "INDEX" Then' w_sheet.Activate' w_sheet.Range("A1").Select' If w_sheet.Range("A1") = "" Or w_sheet.Range("A1") = "※" Or w_sheet.Range("A1") = "INDEX" Then'' w_sheet.Range("A1").Select' w_sheet.Range("A1").FormulaR1C1 = "※"' w_sheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="INDEX!A1", TextToDisplay:="※"' If w_sheet.Range("A1").Interior.Pattern <> xlNone Then '無' With w_sheet.Range("A1").Font' .ThemeColor = xlThemeColorDark1' .TintAndShade = 0' End With' End If'' If w_sheet.Range("A2").Value = "(LINK)" Then' w_sheet.Range("A2").Value = ""' End If'' w_sheet.Range("A1").HorizontalAlignment = xlGeneral' w_sheet.Columns(1).AutoFit'' End If' Sheets("INDEX").Activate' End If i = i + 1 Next w_sheet Application.ScreenUpdating = True Application.EnableEvents = True For Each w_sheet In Sheets If w_sheet.Name <> "INDEX" Then w_sheet.Activate If w_sheet.Range("A1") = "※" Then w_sheet.Range("A1") = "" End If w_sheet.Range("A1").Select End If i = i + 1 Next w_sheet Sheets("INDEX").Activate' If w_rtn = vbYes Then'' s.Columns("A:C").Select' ActiveWorkbook.Worksheets("INDEX").Sort.SortFields.Clear' ActiveWorkbook.Worksheets("INDEX").Sort.SortFields.Add2 Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal' With ActiveWorkbook.Worksheets("INDEX").Sort' .SetRange Range("A:C")' .Header = xlYes' .MatchCase = False' .Orientation = xlTopToBottom' .SortMethod = xlPinYin' .Apply' End With'' Else'' s.Columns("A:C").Select' ActiveWorkbook.Worksheets("INDEX").Sort.SortFields.Clear' ActiveWorkbook.Worksheets("INDEX").Sort.SortFields.Add2 Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal' With ActiveWorkbook.Worksheets("INDEX").Sort' .SetRange Range("A:C")' .Header = xlGuess' .MatchCase = False' .Orientation = xlTopToBottom' .SortMethod = xlPinYin' .Apply' End With'' End If For Each w_sheet In Sheets w_sheet.Activate ActiveWindow.LargeScroll ToLeft:=99 ActiveWindow.LargeScroll Up:=99 w_sheet.Range("A1").Select Next w_sheet
s.Activate s.Cells.Font.Name = "游ゴシック" s.Cells.EntireColumn.AutoFit s.Cells(1, 1).Select
Application.DisplayAlerts = True Application.StatusBar = False
End Sub
s.Activate s.Cells.Font.Name = "游ゴシック" s.Cells.EntireColumn.AutoFit s.Cells(1, 1).Select
Application.DisplayAlerts = True Application.StatusBar = False
End Sub
A1選択
A1選択
Sub ブック_A1選択() '全シートのA1を選択する。 Dim w_sheet As Worksheet Application.DisplayAlerts = False Application.ScreenUpdating = True Application.EnableEvents = True For Each w_sheet In Sheets w_sheet.Activate ActiveWindow.LargeScroll ToLeft:=99 ActiveWindow.LargeScroll Up:=99 w_sheet.Range("A1").Select Next w_sheet Application.DisplayAlerts = True Application.StatusBar = False Sheets(1).Activate End Sub
名前表示
名前表示
Sub ブック_名前表示() '非表示になっている名前を表示する Dim name As Object For Each name In Names If name.Visible = False Then name.Visible = True End If Next MsgBox "すべての名前の定義を表示しました。", vbOKOnly End Sub
入力規則削除
入力規則削除
Sub ブック_入力規則削除()
Dim ws As Worksheet If MsgBox("全シートの入力規則を削除しますか？", vbYesNo) = vbNo Then Exit Sub End If For Each ws In Worksheets ws.Cells.Validation.Delete Next ws
End Sub
Dim ws As Worksheet If MsgBox("全シートの入力規則を削除しますか？", vbYesNo) = vbNo Then Exit Sub End If For Each ws In Worksheets ws.Cells.Validation.Delete Next ws
End Sub