設定

A1ダブルクリックで実行

入力規則設定

入力による書式設定

テーブル設定

A1ダブルクリックで実行

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address = "$A$1" Then Call ファイル名変更_Click Target.Offset(1, 0).Select End If
End Sub

入力規則設定

Sub SetSheetNamesAsValidation()
    Dim ws As Worksheet    Dim sheetNames As String    Dim rng As Range
    '◆ 入力規則設定    Set rng = ActiveSheet.Range("_対象シート")
    For Each ws In ThisWorkbook.Sheets
        If Left(ws.Name, 5) = "原紙コピー" Then            If sheetNames = "" Then                sheetNames = ws.Name            Else                sheetNames = sheetNames & "," & ws.Name            End If        End If
    Next ws
    With rng.Validation
        .Delete        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=sheetNames        .IgnoreBlank = True        .InCellDropdown = True
    End With
End Sub

入力による書式設定

Private Sub Worksheet_Change(ByVal Target As Range)
If Cells(1, Target.Column).Value = "不要" Then Dim w_col As Integer w_col = ActiveSheet.Rows(1).Find(what:="氏名", lookat:=xlWhole).Column With Range(Cells(Target.Row, 1), Cells(Target.Row, w_col)) If .Interior.ColorIndex = 16 Then .Interior.ColorIndex = xlColorIndexNone Else .Interior.ColorIndex = 16 End If End With
End If
End Sub

テーブル設定

Function f_テーブル設定(p_sheet As Worksheet) As Boolean
    f_テーブル設定 = False
    Dim tbl As ListObject        With p_sheet            '◆ テーブルへ変換        If .ListObjects.Count = 0 Then            Set tbl = .ListObjects.Add(xlSrcRange, .UsedRange, , xlYes)            tbl.TableStyle = "TableStyleLight18"        End If                '◆ フィルター解除        If Not .ListObjects(1).AutoFilter Is Nothing Then            .ListObjects(1).Range.AutoFilter        End If                '◆ 幅高さ調整        .Rows.EntireRow.AutoFit        .Cells.EntireColumn.AutoFit                '◆ フィルター設定        .ListObjects(1).Range.AutoFilter
    End With        f_テーブル設定 = True    End Function

列位置設定（1行目）

Public s1_原紙一覧 As WorksheetPublic d_出荷一覧 As Object
Function f_列位置設定_原紙一覧()
    Dim j As Integer
    Set s1_原紙一覧 = Worksheets("原紙一覧")    Set d_原紙一覧 = CreateObject("Scripting.Dictionary")
    With s1_原紙一覧
        For j = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column            If .Cells(1, j).Value <> "" Then                d_原紙一覧.Add Replace(CStr(.Cells(1, j).Value), vbLf, ""), .Cells(1, j).Column            End If        Next j            End With
' Dim key As Variant' Debug.Print "------------------------------"' Debug.Print "d_原紙一覧"' For Each key In d_原紙一覧.Keys' Debug.Print d_原紙一覧(key) & vbTab & key' Next key' Debug.Print "------------------------------"
End Function

列位置設定（2行目）

Public d_出荷元一覧 As Object
Function f_列位置設定_出荷元一覧()
    Dim j As Integer    Dim w_str As String
    Set d_出荷元一覧 = CreateObject("Scripting.Dictionary")        With s0b_出荷元一覧
        For j = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column            If .Cells(1, j).Value <> "" Then                d_出荷元一覧.Add Replace(CStr(.Cells(1, j).Value), vbLf, ""), .Cells(1, j).Column            End If        Next j                For j = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column                        If .Cells(1, j).Value <> "" Then                w_str = .Cells(1, j).Value            End If                        If .Cells(2, j).Value <> "" Then                d_出荷元一覧.Add w_str & Replace(CStr(.Cells(2, j).Value), vbLf, ""), .Cells(2, j).Column            End If                    Next j            End With
' Dim key As Variant' Debug.Print "------------------------------"' Debug.Print "d_出荷元一覧"' For Each key In d_出荷元一覧.Keys' Debug.Print d_出荷元一覧(key) & vbTab & key' Next key' Debug.Print "------------------------------"
End Function

グループを折りたたむ

Private Sub Workbook_Open() Dim ws As Worksheet Dim col As Integer Dim row As Integer ' 各ワークシートに対して処理 For Each ws In ThisWorkbook.Worksheets ' 列グループを折りたたむ For col = 1 To ws.UsedRange.Columns.Count If ws.Columns(col).EntireColumn.OutlineLevel > 1 Then ws.Columns(col).ShowDetail = False End If Next col ' 行グループを折りたたむ For row = 1 To ws.UsedRange.Rows.Count If ws.Rows(row).EntireRow.OutlineLevel > 1 Then ws.Rows(row).ShowDetail = False End If Next row Next ws MsgBox "すべてのグループが折りたたまれました"End Sub

フィルタ

Sub FilterColumnL() Dim ws As Worksheet Dim rng As Range ' シートを指定 Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適宜変更してください ' フィルタをかける範囲を指定 Set rng = ws.Range("A1").CurrentRegion ' データの範囲を自動的に選択 ' L列にフィルタを適用 (12列目) rng.AutoFilter Field:=12, Criteria1:="フィルタ条件" ' Criteria1を適宜変更してくださいEnd Sub

ソート

Sub SortMultipleColumns() Dim ws As Worksheet Dim rng As Range ' シートを指定 Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適宜変更してください ' ソートする範囲を指定 Set rng = ws.Range("A1:D10") ' ソートする範囲を適宜変更してください ' ソートの設定 rng.Sort Key1:=ws.Range("A1"), Order1:=xlAscending, _ Key2:=ws.Range("B1"), Order2:=xlDescending, _ Key3:=ws.Range("C1"), Order3:=xlAscending, Header:=xlYesEnd Sub

指定履歴追加

Function f_指定履歴追加(p_path As String, p_address As String) As Boolean
    f_指定履歴追加 = False
    Dim ws As Worksheet    Dim searchRange As Range    Dim foundCell As Range    Dim searchValue As String
    Set ws = ThisWorkbook.Worksheets("指定履歴")    Set searchRange = ws.Cells        searchValue = p_path    Set foundCell = searchRange.Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)        If Not foundCell Is Nothing Then        ws.Range(foundCell.Address).Delete Shift:=xlUp    End If
    Select Case p_address    Case Range("_対象フォルダ").Address        ws.Range("A1").Insert Shift:=xlDown        ws.Range("A1").Value = p_path    End Select        ws.Cells.EntireColumn.AutoFit        f_指定履歴追加 = True
End Function

ハイパーリンク削除

Private Sub Worksheet_Change(ByVal Target As Range)
'◆ハイパーリンク削除 Dim w_range As Range Select Case Target.Address Case Range("_①").Address, Range("_②").Address Set w_range = Target.MergeArea Target.Hyperlinks.Delete With w_range .Merge With .Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent5 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With With .Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With .Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With .Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With .Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With .Font .Name = "Meiryo UI" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 .ThemeFont = xlThemeFontNone End With End With '◆指定履歴追加 If f_指定履歴追加(Target.Value, Target.Address) = False Then MsgBox "指定履歴の追加が、できませんでした。", vbOKOnly + vbExclamation, "指定履歴追加エラー" End If
End Select
End Sub