Excel VBAサンプル
個人用マクロブックのパス
個人用マクロブックのパス
C:\Users\hamamoto\AppData\Roaming\Microsoft\Excel\XLSTART
ブック
ブック
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
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
見出し
見出し
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
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
列
列
幅
幅
Sub 列_幅()
'列幅を自動調整する With Selection(1) If .ColumnWidth > 200 Then Selection.ColumnWidth = 200 ElseIf .ColumnWidth > 100 Then Selection.ColumnWidth = 100 ElseIf .ColumnWidth > 50 Then Selection.ColumnWidth = 50 ElseIf .ColumnWidth > 10 Then Selection.ColumnWidth = 10 ElseIf .ColumnWidth > 2 Then Selection.ColumnWidth = 2 ElseIf .ColumnWidth > 1 Then Selection.ColumnWidth = 1 Else Selection.ColumnWidth = 200 End If
End With End Sub
'列幅を自動調整する With Selection(1) If .ColumnWidth > 200 Then Selection.ColumnWidth = 200 ElseIf .ColumnWidth > 100 Then Selection.ColumnWidth = 100 ElseIf .ColumnWidth > 50 Then Selection.ColumnWidth = 50 ElseIf .ColumnWidth > 10 Then Selection.ColumnWidth = 10 ElseIf .ColumnWidth > 2 Then Selection.ColumnWidth = 2 ElseIf .ColumnWidth > 1 Then Selection.ColumnWidth = 1 Else Selection.ColumnWidth = 200 End If
End With End Sub
灰色列非表示
灰色列非表示
Sub 列_灰色列非表示()
'選択範囲で灰色のセルの列を非表示にする。 Dim s As Worksheet Dim r_start As Long Dim r_end As Long Dim c_start As Long Dim c_end As Long Dim i As Long Dim j As Long
If Selection.Rows.Count > 1 Then MsgBox "1行だけ選択してください。" Exit Sub End If
Selection.Columns.Hidden = False
Set s = ActiveSheet With s.UsedRange r_start = .Row r_end = .Row + .Rows.Count - 1 c_start = .Column c_end = .Column + .Columns.Count - 1 End With With Selection If .Row > r_start Then r_start = .Row End If If .Row + .Rows.Count - 1 < r_end Then r_end = .Row + .Rows.Count - 1 End If If .Column > c_start Then c_start = .Column End If If .Column + .Columns.Count - 1 < c_end Then c_end = .Column + .Columns.Count - 1 End If End With For j = c_start To c_end If s.Cells(r_start, j).Interior.ColorIndex = 15 Or s.Cells(r_start, j).Interior.ColorIndex = 16 Then s.Columns(j).Hidden = True End If Next j
End Sub
'選択範囲で灰色のセルの列を非表示にする。 Dim s As Worksheet Dim r_start As Long Dim r_end As Long Dim c_start As Long Dim c_end As Long Dim i As Long Dim j As Long
If Selection.Rows.Count > 1 Then MsgBox "1行だけ選択してください。" Exit Sub End If
Selection.Columns.Hidden = False
Set s = ActiveSheet With s.UsedRange r_start = .Row r_end = .Row + .Rows.Count - 1 c_start = .Column c_end = .Column + .Columns.Count - 1 End With With Selection If .Row > r_start Then r_start = .Row End If If .Row + .Rows.Count - 1 < r_end Then r_end = .Row + .Rows.Count - 1 End If If .Column > c_start Then c_start = .Column End If If .Column + .Columns.Count - 1 < c_end Then c_end = .Column + .Columns.Count - 1 End If End With For j = c_start To c_end If s.Cells(r_start, j).Interior.ColorIndex = 15 Or s.Cells(r_start, j).Interior.ColorIndex = 16 Then s.Columns(j).Hidden = True End If Next j
End Sub
罫線
罫線
右二重線
Sub 罫線_右二重線() 'セルの右に二重罫線を引く With Selection.Borders(xlEdgeRight) .LineStyle = xlDouble .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThick End With
End Sub
End Sub
塗りつぶし
塗りつぶし
緑色
Sub 塗りつぶし_緑色() If Selection(1).Interior.ThemeColor = xlThemeColorAccent6 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent6 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.ThemeColor = xlThemeColorAccent6 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0.4 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent6 .TintAndShade = 0.599993896298105 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.ThemeColor = xlThemeColorAccent6 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0.6 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent6 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.ThemeColor = xlThemeColorAccent6 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0.8 Then With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ColorIndex = xlAutomatic .TintAndShade = 0 End With Else With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent6 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If
End Sub
End Sub
水色
Sub 塗りつぶし_水色() If Selection(1).Interior.ThemeColor = xlThemeColorAccent5 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent5 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.ThemeColor = xlThemeColorAccent5 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0.4 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent5 .TintAndShade = 0.599993896298105 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.ThemeColor = xlThemeColorAccent5 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0.6 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent5 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.ThemeColor = xlThemeColorAccent5 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0.8 Then With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ColorIndex = xlAutomatic .TintAndShade = 0 End With Else With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent5 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If
End Sub
End Sub
橙色
Sub 塗りつぶし_橙色() If Selection(1).Interior.ThemeColor = xlThemeColorAccent4 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.ThemeColor = xlThemeColorAccent4 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0.4 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 .TintAndShade = 0.599993896298105 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.ThemeColor = xlThemeColorAccent4 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0.6 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With ElseIf Selection(1).Interior.ThemeColor = xlThemeColorAccent4 _ And Round(Selection(1).Interior.TintAndShade, 2) = 0.8 Then With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ColorIndex = xlAutomatic .TintAndShade = 0 End With Else With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If
End Sub
End Sub
黄赤
Sub 塗りつぶし_黄赤() If Selection(1).Interior.Color = 65535 Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With ElseIf Selection(1).Interior.Color = 255 Then With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ColorIndex = xlAutomatic .TintAndShade = 0 End With Else With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ColorIndex = xlAutomatic .TintAndShade = 0 End With End If
End Sub
End Sub
図形
図形
枠線
Sub 図形_枠線()
'図形の枠線の表示、非表示 If Selection.ShapeRange.Fill.Visible = msoFalse Then Selection.ShapeRange.Line.Visible = msoTrue With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 '黒 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Weight = 0.25 End With With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 '白 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With Else Selection.ShapeRange.Fill.Visible = msoFalse With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) '赤 .Transparency = 0 .Weight = 3 End With End If End Sub
'図形の枠線の表示、非表示 If Selection.ShapeRange.Fill.Visible = msoFalse Then Selection.ShapeRange.Line.Visible = msoTrue With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 '黒 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Weight = 0.25 End With With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 '白 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With Else Selection.ShapeRange.Fill.Visible = msoFalse With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) '赤 .Transparency = 0 .Weight = 3 End With End If End Sub
塗りつぶし
Sub 図形_塗りつぶし()
'図形の塗りつぶしを自動設定 On Error Resume Next With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Weight = 0.25 End With
If Selection.ShapeRange.Fill.Visible <> msoTrue Then
If Selection.ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1 Then With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(255, 255, 0) '黄 .Transparency = 0 .Solid End With With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) '黒 .Transparency = 0 .Solid End With ElseIf Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0) Then With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) '赤 .Transparency = 0 .Solid End With With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 '白 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With ElseIf Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0) Then With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 176, 240) '青 .Transparency = 0 .Solid End With With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) '黒 .Transparency = 0 .Solid End With ElseIf Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 240) Then Selection.ShapeRange.Fill.Visible = msoFalse '透明 With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) '黒 .Transparency = 0 .Solid End With End If Else With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 '白 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) '黒 .Transparency = 0 .Solid End With End If Selection.ShapeRange.SetShapesDefaultProperties
On Error GoTo 0
End Sub
'図形の塗りつぶしを自動設定 On Error Resume Next With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Weight = 0.25 End With
If Selection.ShapeRange.Fill.Visible <> msoTrue Then
If Selection.ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1 Then With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(255, 255, 0) '黄 .Transparency = 0 .Solid End With With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) '黒 .Transparency = 0 .Solid End With ElseIf Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 0) Then With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) '赤 .Transparency = 0 .Solid End With With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 '白 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With ElseIf Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0) Then With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 176, 240) '青 .Transparency = 0 .Solid End With With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) '黒 .Transparency = 0 .Solid End With ElseIf Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 240) Then Selection.ShapeRange.Fill.Visible = msoFalse '透明 With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) '黒 .Transparency = 0 .Solid End With End If Else With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 '白 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 .Solid End With With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 0, 0) '黒 .Transparency = 0 .Solid End With End If Selection.ShapeRange.SetShapesDefaultProperties
On Error GoTo 0
End Sub
赤矢印
Sub 図形_赤矢印()
'矢印を赤太線にする With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) .Transparency = 0 .Weight = 6 End With
Selection.ShapeRange.SetShapesDefaultProperties
End Sub
'矢印を赤太線にする With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) .Transparency = 0 .Weight = 6 End With
Selection.ShapeRange.SetShapesDefaultProperties
End Sub
張替え
Sub 図形_張替え()
'図形を張り替える
Dim x As Single Dim y As Single Dim w As Single Dim z As Single Dim w_row As Integer Dim w_column As Integer
On Error GoTo l_error
x = Selection.Top y = Selection.Left w = Selection.Width z = Selection.Zoom
w_row = 1 Do Until Cells(w_row, 1).Top >= x w_row = w_row + 1 Loop
w_column = 1 Do Until Cells(1, w_column).Left >= y w_column = w_column + 1 Loop
Selection.Delete Cells(w_row, w_column).Select ActiveSheet.Paste Selection.Top = x Selection.Left = y' Selection.Width = w Selection.Zoom = z Selection.ShapeRange.ZOrder msoSendToBack
l_error:
End Sub
'図形を張り替える
Dim x As Single Dim y As Single Dim w As Single Dim z As Single Dim w_row As Integer Dim w_column As Integer
On Error GoTo l_error
x = Selection.Top y = Selection.Left w = Selection.Width z = Selection.Zoom
w_row = 1 Do Until Cells(w_row, 1).Top >= x w_row = w_row + 1 Loop
w_column = 1 Do Until Cells(1, w_column).Left >= y w_column = w_column + 1 Loop
Selection.Delete Cells(w_row, w_column).Select ActiveSheet.Paste Selection.Top = x Selection.Left = y' Selection.Width = w Selection.Zoom = z Selection.ShapeRange.ZOrder msoSendToBack
l_error:
End Sub
コメントのサイズ自動調整
Sub 図形_コメントのサイズ自動調整()
'選択したセルのコメントのサイズを自動調整する。
ActiveCell.Comment.Shape.TextFrame.AutoSize = True
End Sub
'選択したセルのコメントのサイズを自動調整する。
ActiveCell.Comment.Shape.TextFrame.AutoSize = True
End Sub
サイズ自動調整
Sub 図形_サイズ自動調整()
'選択した図形のサイズを自動調整する。
Selection.ShapeRange.TextFrame.AutoSize = True
End Sub
'選択した図形のサイズを自動調整する。
Selection.ShapeRange.TextFrame.AutoSize = True
End Sub
サイズ90
Sub 図形_サイズ90() '図形のサイズを90%にする。 Selection.ShapeRange.ScaleHeight 0.9, msoFalse, msoScaleFromTopLeft End Sub
置換
置換
置換①
置換①
Sub 置換_置換①()
' Selection.Replace What:="１．", Replacement:="１ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2' Selection.Replace What:="２．", Replacement:="２ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2' Selection.Replace What:="３．", Replacement:="３ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2' Selection.Replace What:="４．", Replacement:="４ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2' Selection.Replace What:="５．", Replacement:="５ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'サービス配達先 Selection.Replace What:="サービス配達先", Replacement:="サービス配送先", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '（ハイフン付き） Selection.Replace What:="（ハイフン付き）", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '要介護認定状況コード（未申請～介護５） Selection.Replace What:="要介護認定状況コード（未申請～介護５）", Replacement:="要介護度", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '個人番号／移行データ番号（任意） Selection.Replace What:="個人番号／移行データ番号（任意）", Replacement:="移行データ番号（任意）", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日（最終） Selection.Replace What:="決定年月日（最終）", Replacement:="決定年月日", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 決定 Selection.Replace What:="決定年月日 決定", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 変更 Selection.Replace What:="決定年月日 変更", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 廃止 Selection.Replace What:="決定年月日 廃止", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 却下 Selection.Replace What:="決定年月日 却下", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定区分 （最終） Selection.Replace What:="決定区分 （最終）", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '世帯市民 Selection.Replace What:="世帯市民", Replacement:="世帯", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '介護保険料の所得段階区分 Selection.Replace What:="介護保険料の所得段階区分", Replacement:="階層（減免ありの所得段階区分）", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定以外の理由（最終） Selection.Replace What:="決定以外の理由（最終）", Replacement:="決定以外の理由", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 Selection.Replace What:="決定年月日", Replacement:="決定年月日" & Chr(10) & "決定区分", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定区分 Selection.Replace What:="決定区分", Replacement:="決定年月日" & Chr(10) & "決定区分", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '階層 Selection.Replace What:="階層", Replacement:="階層（減免ありの所得段階区分）", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
' Selection.Replace What:="１．", Replacement:="１ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2' Selection.Replace What:="２．", Replacement:="２ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2' Selection.Replace What:="３．", Replacement:="３ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2' Selection.Replace What:="４．", Replacement:="４ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2' Selection.Replace What:="５．", Replacement:="５ ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'サービス配達先 Selection.Replace What:="サービス配達先", Replacement:="サービス配送先", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '（ハイフン付き） Selection.Replace What:="（ハイフン付き）", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '要介護認定状況コード（未申請～介護５） Selection.Replace What:="要介護認定状況コード（未申請～介護５）", Replacement:="要介護度", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '個人番号／移行データ番号（任意） Selection.Replace What:="個人番号／移行データ番号（任意）", Replacement:="移行データ番号（任意）", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日（最終） Selection.Replace What:="決定年月日（最終）", Replacement:="決定年月日", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 決定 Selection.Replace What:="決定年月日 決定", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 変更 Selection.Replace What:="決定年月日 変更", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 廃止 Selection.Replace What:="決定年月日 廃止", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 却下 Selection.Replace What:="決定年月日 却下", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定区分 （最終） Selection.Replace What:="決定区分 （最終）", Replacement:="決定区分", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '世帯市民 Selection.Replace What:="世帯市民", Replacement:="世帯", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '介護保険料の所得段階区分 Selection.Replace What:="介護保険料の所得段階区分", Replacement:="階層（減免ありの所得段階区分）", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定以外の理由（最終） Selection.Replace What:="決定以外の理由（最終）", Replacement:="決定以外の理由", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定年月日 Selection.Replace What:="決定年月日", Replacement:="決定年月日" & Chr(10) & "決定区分", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '決定区分 Selection.Replace What:="決定区分", Replacement:="決定年月日" & Chr(10) & "決定区分", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '階層 Selection.Replace What:="階層", Replacement:="階層（減免ありの所得段階区分）", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub
置換②
置換②
Sub 置換_置換②()
Selection.Replace What:="「", Replacement:="""", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2 Selection.Replace What:="」", Replacement:="""", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End Sub
Selection.Replace What:="「", Replacement:="""", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2 Selection.Replace What:="」", Replacement:="""", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End Sub
ファイル
ファイル
ファイル選択
Sub ファイル_ファイル選択()
'ファイルを選択して、パスを取得
Dim w_ret As Integer
With Application.FileDialog(msoFileDialogFilePicker) .Title = "ファイルを選択してください。" .Filters.Clear .Filters.Add "すべて", "*.*" .FilterIndex = 1 .AllowMultiSelect = False .InitialFileName = ActiveWorkbook.Path & "\" w_ret = .Show If w_ret <> 0 Then ActiveCell = .SelectedItems.Item(1) Else MsgBox "キャンセルされました。", vbInformation, "ファイル選択" End If End With
End Sub
'ファイルを選択して、パスを取得
Dim w_ret As Integer
With Application.FileDialog(msoFileDialogFilePicker) .Title = "ファイルを選択してください。" .Filters.Clear .Filters.Add "すべて", "*.*" .FilterIndex = 1 .AllowMultiSelect = False .InitialFileName = ActiveWorkbook.Path & "\" w_ret = .Show If w_ret <> 0 Then ActiveCell = .SelectedItems.Item(1) Else MsgBox "キャンセルされました。", vbInformation, "ファイル選択" End If End With
End Sub
フォルダ選択
Sub ファイル_フォルダ選択()
'フォルダを選択して、パスを取得 Dim w_ret As Integer
With Application.FileDialog(msoFileDialogFolderPicker) .Title = "フォルダを選択してください。" .AllowMultiSelect = False .InitialFileName = ActiveWorkbook.Path & "\" w_ret = .Show If w_ret <> 0 Then ActiveCell = .SelectedItems.Item(1) & "\" Else MsgBox "キャンセルされました。", vbInformation, "フォルダ選択" End If End With
End Sub
'フォルダを選択して、パスを取得 Dim w_ret As Integer
With Application.FileDialog(msoFileDialogFolderPicker) .Title = "フォルダを選択してください。" .AllowMultiSelect = False .InitialFileName = ActiveWorkbook.Path & "\" w_ret = .Show If w_ret <> 0 Then ActiveCell = .SelectedItems.Item(1) & "\" Else MsgBox "キャンセルされました。", vbInformation, "フォルダ選択" End If End With
End Sub
ログ出力
Sub ファイル_ログ出力()
Dim FileNumber Dim w_str As String
'■ ログファイルオープン Close #FileNumber FileNumber = FreeFile If ActiveWorkbook.Path = "" Or Mid(ActiveWorkbook.Path, InStrRev(ActiveWorkbook.Path, "\") + 1, 99) = "XLSTART" Then w_str = "D:" Else w_str = ActiveWorkbook.Path End If Debug.Print "ActiveWorkbook.Path=" & ActiveWorkbook.Path Debug.Print "⇒" & w_str Open w_str & "\LOG.txt" For Output As #FileNumber
'■ ログファイル出力 Print #FileNumber, "--------------------------------------------------" Print #FileNumber, "aaaaaaaaaaaaaaaaaa"
'■ ログファイルクローズ Close #FileNumber
End Sub
Dim FileNumber Dim w_str As String
'■ ログファイルオープン Close #FileNumber FileNumber = FreeFile If ActiveWorkbook.Path = "" Or Mid(ActiveWorkbook.Path, InStrRev(ActiveWorkbook.Path, "\") + 1, 99) = "XLSTART" Then w_str = "D:" Else w_str = ActiveWorkbook.Path End If Debug.Print "ActiveWorkbook.Path=" & ActiveWorkbook.Path Debug.Print "⇒" & w_str Open w_str & "\LOG.txt" For Output As #FileNumber
'■ ログファイル出力 Print #FileNumber, "--------------------------------------------------" Print #FileNumber, "aaaaaaaaaaaaaaaaaa"
'■ ログファイルクローズ Close #FileNumber
End Sub
処理
処理
開始
Sub 処理_開始()
'開始処理
Application.StatusBar = "開始"
Application.Cursor = xlWait Application.DisplayAlerts = False Application.ScreenUpdating = False Application.CutCopyMode = False End Sub
'開始処理
Application.StatusBar = "開始"
Application.Cursor = xlWait Application.DisplayAlerts = False Application.ScreenUpdating = False Application.CutCopyMode = False End Sub
終了
Sub 処理_終了()
'終了処理
Application.CutCopyMode = False
Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Cursor = xlDefault Application.StatusBar = False
End Sub
'終了処理
Application.CutCopyMode = False
Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Cursor = xlDefault Application.StatusBar = False
End Sub
エラーメッセージ
Sub 処理_エラーメッセージ()
'エラーメッセージ表示
On Error Resume Next MsgBox 100 / 0 If Err.Number <> 0 Then MsgBox Err.Description & "（" & Err.Number & "）", vbCritical End If On Error GoTo 0
End Sub
'エラーメッセージ表示
On Error Resume Next MsgBox 100 / 0 If Err.Number <> 0 Then MsgBox Err.Description & "（" & Err.Number & "）", vbCritical End If On Error GoTo 0
End Sub
エラー処理
Sub 処理_エラー処理()
On Error Resume Next Err.Clear If Err.Number <> 0 Then MsgBox "エラー" Exit Sub End If On Error GoTo 0 End Sub
On Error Resume Next Err.Clear If Err.Number <> 0 Then MsgBox "エラー" Exit Sub End If On Error GoTo 0 End Sub
接続実行切断
'「Microsoft ActiveX Data Objects X.X Library」を有効にする。
'Windows認証で接続する場合Public Const PROVIDER As String = "SQLOLEDB"Public DATA_SOURCE As String 'サーバ名Public DATABASE As String 'データベース名
'SQL Server認証で接続する場合Public Const USER_ID As String = "UID=user" 'ユーザIDPublic Const PASSWORD As String = "password" 'ユーザパスワード
Public cn As New ADODB.ConnectionPublic rs As New ADODB.Recordset
Public strSQL As String
Sub データベース_接続実行切断()
'■ サーバー情報設定 DATA_SOURCE = "PC1665\SQLEXPRESS" DATABASE = "KZSDB_xxxxx" '-------------------------------- ' データベース接続 '-------------------------------- 'Windows認証で接続する場合 cn.ConnectionString = "Provider=" & PROVIDER _ & ";Data Source=" & DATA_SOURCE _ & ";Initial Catalog=" & DATABASE _ & ";Trusted_Connection=Yes" cn.Open
' 'SQL Server認証で接続する場合' cn.ConnectionString = "Provider=" & PROVIDER _' & ";Data Source=" & DATA_SOURCE _' & ";Initial Catalog=" & DATABASE _' & ";UID=" & USER_ID _' & ";PWD=" & PASSWORD' cn.Open
strSQL = "SELECT MAX([SIKIBETSUNO]) FROM TBL_JJYUKI" Debug.Print strSQL '-------------------------------- ' SQLの実行 '-------------------------------- If Not rs Is Nothing Then Set rs = Nothing End If rs.Open strSQL, cn
If rs.RecordCount > 0 Then Debug.Print "⇒SIKIBETSUNO=" & rs![SIKIBETSUNO] Else Debug.Print "⇒s.RecordCount=" & rs.RecordCount End If
'-------------------------------- ' データベース切断 '-------------------------------- If Not rs Is Nothing Then If rs.State = adStateOpen Then rs.Close Set rs = Nothing End If If Not cn Is Nothing Then If cn.State = adStateOpen Then cn.Close Set cn = Nothing End If
End Sub
'Windows認証で接続する場合Public Const PROVIDER As String = "SQLOLEDB"Public DATA_SOURCE As String 'サーバ名Public DATABASE As String 'データベース名
'SQL Server認証で接続する場合Public Const USER_ID As String = "UID=user" 'ユーザIDPublic Const PASSWORD As String = "password" 'ユーザパスワード
Public cn As New ADODB.ConnectionPublic rs As New ADODB.Recordset
Public strSQL As String
Sub データベース_接続実行切断()
'■ サーバー情報設定 DATA_SOURCE = "PC1665\SQLEXPRESS" DATABASE = "KZSDB_xxxxx" '-------------------------------- ' データベース接続 '-------------------------------- 'Windows認証で接続する場合 cn.ConnectionString = "Provider=" & PROVIDER _ & ";Data Source=" & DATA_SOURCE _ & ";Initial Catalog=" & DATABASE _ & ";Trusted_Connection=Yes" cn.Open
' 'SQL Server認証で接続する場合' cn.ConnectionString = "Provider=" & PROVIDER _' & ";Data Source=" & DATA_SOURCE _' & ";Initial Catalog=" & DATABASE _' & ";UID=" & USER_ID _' & ";PWD=" & PASSWORD' cn.Open
strSQL = "SELECT MAX([SIKIBETSUNO]) FROM TBL_JJYUKI" Debug.Print strSQL '-------------------------------- ' SQLの実行 '-------------------------------- If Not rs Is Nothing Then Set rs = Nothing End If rs.Open strSQL, cn
If rs.RecordCount > 0 Then Debug.Print "⇒SIKIBETSUNO=" & rs![SIKIBETSUNO] Else Debug.Print "⇒s.RecordCount=" & rs.RecordCount End If
'-------------------------------- ' データベース切断 '-------------------------------- If Not rs Is Nothing Then If rs.State = adStateOpen Then rs.Close Set rs = Nothing End If If Not cn Is Nothing Then If cn.State = adStateOpen Then cn.Close Set cn = Nothing End If
End Sub
一時保存用
一時保存用
シート
シート
Option Explicit
Sub シート_区切り無し()
If Range("A1").Value = "" Then Range("A1").Value = "x" End If Range("A1").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 2), TrailingMinusNumbers:=True If Range("A1").Value = "x" Then Range("A1").Value = "" End If End Sub
Sub シート_vba編集()
Dim s As Worksheet Dim i As Long Dim r_end As Long Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With If s.Cells(1, 1).Value <> "●" Then s.Range("A1").EntireRow.Insert s.Range("A1").EntireColumn.Insert s.Range("A1").EntireColumn.Insert s.Cells(1, 1) = "●" s.Cells(1, 2) = "分類" s.Cells(1, 3) = "コード" End If Call シート_テーブル化 s.Range(s.Cells(2, 1), s.Cells(r_end, 2)).ClearContents For i = 2 To r_end If InStr(1, s.Cells(i, 3).Value, "Sub ") > 0 Then s.Cells(i, 1).Value = "●" s.Cells(i, 2).Value = "Sub" With s.Range(s.Cells(i, 1), s.Cells(i, 3)).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 49407 '橙 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If If InStr(1, s.Cells(i, 3).Value, "Function ") > 0 Then s.Cells(i, 1).Value = "●" s.Cells(i, 2).Value = "Function" With s.Range(s.Cells(i, 1), s.Cells(i, 3)).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 49407 '橙 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If If InStr(1, s.Cells(i, 3).Value, "Dim ") > 0 Then s.Cells(i, 2).Value = "Dim" With s.Range(s.Cells(i, 3), s.Cells(i, 3)).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 '青 .TintAndShade = 0.8 .PatternTintAndShade = 0 End With End If If Left(s.Cells(i, 3).Value, 1) = "'" Then s.Cells(i, 2).Value = "''" With s.Cells(i, 3).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ColorIndex = 15 '灰 .TintAndShade = 0 .PatternTintAndShade = 0 End With If s.Cells(i - 1, 3).Value = "" And Left(s.Cells(i - 2, 3).Value, 1) = "'" Then With s.Cells(i - 1, 3).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ColorIndex = 15 '灰 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If End If Next i
s.Cells.EntireColumn.AutoFit
End Sub
Sub シート_テーブル化()
Dim w_range As Range Dim w_str As String On Error Resume Next ActiveSheet.ListObjects(1).Unlist On Error GoTo 0 If Selection(1).Value = "" Then Selection(1).Value = "AAA" End If If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then ActiveSheet.UsedRange.Select Cells.ColumnWidth = 2 ElseIf Selection.Rows.Count > ActiveSheet.UsedRange.Rows.Count Or Selection.Columns.Count > ActiveSheet.UsedRange.Columns.Count Then ActiveSheet.UsedRange.Select Cells.ColumnWidth = 2 End If With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .Size = 12 End With Selection.Font.Bold = False With Selection.Font .Size = 12 End With 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 w_str = "t_" & ActiveSheet.name ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).name = w_str ActiveSheet.ListObjects(w_str).TableStyle = "TableStyleMedium13"
Range(w_str).Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Rows("1:1") .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False If ActiveSheet.ListObjects(w_str).ListColumns.Count > 20 Then .Orientation = xlVertical End If .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With
Range(w_str & "[#All]").Select Selection.ColumnWidth = 50 Selection.Columns.AutoFit Selection.Rows.AutoFit For Each w_range In ActiveSheet.ListObjects(w_str).HeaderRowRange Select Case w_range.Value Case "日付", "作成日", "更新日" w_range.EntireColumn.NumberFormatLocal = "yyyy-mm-dd;@" w_range.EntireColumn.AutoFit ActiveSheet.DisplayPageBreaks = False End Select Next w_range On Error GoTo l_wnd Range("t_時間集計[#Headers]").Select With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False .Orientation = xlVertical .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Range("t_時間集計[#All]").Select Selection.Columns.AutoFit l_end: Rows("2:2").Select ActiveWindow.FreezePanes = True Range("A1").Select
End Sub
Sub シート_一覧調整() Cells.ColumnWidth = 2 Rows("1:1").Select With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False .Orientation = xlVertical .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Rows("2:2").Select ActiveWindow.FreezePanes = True Cells.Select Selection.AutoFilter Selection.Columns.AutoFit Range("A1").Select End Sub
Sub シート_表示() Dim w_sheet As Worksheet If ActiveWorkbook.ProtectStructure Then MsgBox "ブックの保護を解除してください" Exit Sub End If For Each w_sheet In ActiveWorkbook.Sheets w_sheet.Visible = xlSheetVisible Next w_sheet
End Sub
Sub シート_非表示() Dim w_sheet As Worksheet For Each w_sheet In ActiveWorkbook.Sheets Select Case w_sheet.Name Case "入力説明", "入力シート", "入力選択肢" Case Else w_sheet.Visible = xlSheetHidden End Select Next w_sheet
End Sub
Sub シート_区切り無し()
If Range("A1").Value = "" Then Range("A1").Value = "x" End If Range("A1").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 2), TrailingMinusNumbers:=True If Range("A1").Value = "x" Then Range("A1").Value = "" End If End Sub
Sub シート_vba編集()
Dim s As Worksheet Dim i As Long Dim r_end As Long Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With If s.Cells(1, 1).Value <> "●" Then s.Range("A1").EntireRow.Insert s.Range("A1").EntireColumn.Insert s.Range("A1").EntireColumn.Insert s.Cells(1, 1) = "●" s.Cells(1, 2) = "分類" s.Cells(1, 3) = "コード" End If Call シート_テーブル化 s.Range(s.Cells(2, 1), s.Cells(r_end, 2)).ClearContents For i = 2 To r_end If InStr(1, s.Cells(i, 3).Value, "Sub ") > 0 Then s.Cells(i, 1).Value = "●" s.Cells(i, 2).Value = "Sub" With s.Range(s.Cells(i, 1), s.Cells(i, 3)).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 49407 '橙 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If If InStr(1, s.Cells(i, 3).Value, "Function ") > 0 Then s.Cells(i, 1).Value = "●" s.Cells(i, 2).Value = "Function" With s.Range(s.Cells(i, 1), s.Cells(i, 3)).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 49407 '橙 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If If InStr(1, s.Cells(i, 3).Value, "Dim ") > 0 Then s.Cells(i, 2).Value = "Dim" With s.Range(s.Cells(i, 3), s.Cells(i, 3)).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 '青 .TintAndShade = 0.8 .PatternTintAndShade = 0 End With End If If Left(s.Cells(i, 3).Value, 1) = "'" Then s.Cells(i, 2).Value = "''" With s.Cells(i, 3).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ColorIndex = 15 '灰 .TintAndShade = 0 .PatternTintAndShade = 0 End With If s.Cells(i - 1, 3).Value = "" And Left(s.Cells(i - 2, 3).Value, 1) = "'" Then With s.Cells(i - 1, 3).Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ColorIndex = 15 '灰 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If End If Next i
s.Cells.EntireColumn.AutoFit
End Sub
Sub シート_テーブル化()
Dim w_range As Range Dim w_str As String On Error Resume Next ActiveSheet.ListObjects(1).Unlist On Error GoTo 0 If Selection(1).Value = "" Then Selection(1).Value = "AAA" End If If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then ActiveSheet.UsedRange.Select Cells.ColumnWidth = 2 ElseIf Selection.Rows.Count > ActiveSheet.UsedRange.Rows.Count Or Selection.Columns.Count > ActiveSheet.UsedRange.Columns.Count Then ActiveSheet.UsedRange.Select Cells.ColumnWidth = 2 End If With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .Size = 12 End With Selection.Font.Bold = False With Selection.Font .Size = 12 End With 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 w_str = "t_" & ActiveSheet.name ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).name = w_str ActiveSheet.ListObjects(w_str).TableStyle = "TableStyleMedium13"
Range(w_str).Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Rows("1:1") .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False If ActiveSheet.ListObjects(w_str).ListColumns.Count > 20 Then .Orientation = xlVertical End If .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With
Range(w_str & "[#All]").Select Selection.ColumnWidth = 50 Selection.Columns.AutoFit Selection.Rows.AutoFit For Each w_range In ActiveSheet.ListObjects(w_str).HeaderRowRange Select Case w_range.Value Case "日付", "作成日", "更新日" w_range.EntireColumn.NumberFormatLocal = "yyyy-mm-dd;@" w_range.EntireColumn.AutoFit ActiveSheet.DisplayPageBreaks = False End Select Next w_range On Error GoTo l_wnd Range("t_時間集計[#Headers]").Select With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False .Orientation = xlVertical .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Range("t_時間集計[#All]").Select Selection.Columns.AutoFit l_end: Rows("2:2").Select ActiveWindow.FreezePanes = True Range("A1").Select
End Sub
Sub シート_一覧調整() Cells.ColumnWidth = 2 Rows("1:1").Select With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = False .Orientation = xlVertical .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Rows("2:2").Select ActiveWindow.FreezePanes = True Cells.Select Selection.AutoFilter Selection.Columns.AutoFit Range("A1").Select End Sub
Sub シート_表示() Dim w_sheet As Worksheet If ActiveWorkbook.ProtectStructure Then MsgBox "ブックの保護を解除してください" Exit Sub End If For Each w_sheet In ActiveWorkbook.Sheets w_sheet.Visible = xlSheetVisible Next w_sheet
End Sub
Sub シート_非表示() Dim w_sheet As Worksheet For Each w_sheet In ActiveWorkbook.Sheets Select Case w_sheet.Name Case "入力説明", "入力シート", "入力選択肢" Case Else w_sheet.Visible = xlSheetHidden End Select Next w_sheet
End Sub
セル
セル
Option Explicit
Sub セル_フォント赤()
Dim w_len As Integer
If Selection(1).Font.Color = 255 Then With Selection.Font .ThemeColor = xlThemeColorLight1 '黒 .TintAndShade = 0 End With Else With Selection.Font .Color = 255 '赤 .TintAndShade = 0 End With End If End Sub
Sub セル_入力規則() With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="●,△,×,－" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = False End With End Sub
Sub セル_日付チェック() Dim s As Worksheet Dim r_end As Long Dim w_range As Range Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 For Each w_range In Selection If w_range.Row > r_end Then Exit For End If If w_range <> "" And IsDate(w_range) Then If w_range.Interior.ColorIndex = xlNone And w_range.Interior.ThemeColor = xlNone Then If w_range > DateAdd("m", -6, Date) Then w_range.Interior.ColorIndex = 6 ElseIf w_range > DateAdd("y", -1, Date) Then With w_range.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 '薄黄 .TintAndShade = 0.8 .PatternTintAndShade = 0 End With ElseIf w_range > DateAdd("m", -18, Date) Then With w_range.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 '薄黄 .TintAndShade = 0.8 .PatternTintAndShade = 0 End With End If End If End If Next w_range
End Sub
Sub セル_フォント赤()
Dim w_len As Integer
If Selection(1).Font.Color = 255 Then With Selection.Font .ThemeColor = xlThemeColorLight1 '黒 .TintAndShade = 0 End With Else With Selection.Font .Color = 255 '赤 .TintAndShade = 0 End With End If End Sub
Sub セル_入力規則() With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="●,△,×,－" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = False End With End Sub
Sub セル_日付チェック() Dim s As Worksheet Dim r_end As Long Dim w_range As Range Set s = ActiveSheet With s.UsedRange r_end = .Row + .Rows.Count - 1 End With On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 For Each w_range In Selection If w_range.Row > r_end Then Exit For End If If w_range <> "" And IsDate(w_range) Then If w_range.Interior.ColorIndex = xlNone And w_range.Interior.ThemeColor = xlNone Then If w_range > DateAdd("m", -6, Date) Then w_range.Interior.ColorIndex = 6 ElseIf w_range > DateAdd("y", -1, Date) Then With w_range.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 '薄黄 .TintAndShade = 0.8 .PatternTintAndShade = 0 End With ElseIf w_range > DateAdd("m", -18, Date) Then With w_range.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent4 '薄黄 .TintAndShade = 0.8 .PatternTintAndShade = 0 End With End If End If End If Next w_range
End Sub