ExcelVBA Tip集  

Sub Sort_Selection(v() As Long)
    Dim n As Long, i As Long, j As Long, k As Long
    Dim Min As Long

    n = UBound(v) + 1
    For i = 0 To n - 2
        Min = v(i)
        k = i
        For j = i + 1 To n - 1
            If v(j) < Min Then
                Min = v(j)
                k = j
            End If
        Next
        v(k) = v(i)
        v(i) = Min
    Next
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Dim r As Long, c As Long

    If Sh.Name Like "#月" Or Sh.Name Like "##月" Then '特定のシートのみ
        'Application.EnableEvents = False 'SelectionChangeイベント発生する処理がある場合は記述

        '前回の塗りつぶしクリア
        Cells.Interior.Pattern = xlNone
        'Rows(1).Interior.Pattern = xlNone ★タイトルだけに色を付けたい場合★
        'Columns(1).Interior.Pattern = xlNone ★タイトルだけに色を付けたい場合★

        'If Target.Count = 1 Then '一つのセル選択のみ(Exce2003まで)
        If Target.CountLarge = 1 Then '一つのセル選択のみ(Exce2007から)
           '選択セルの行番号と列番号の取得
            r = Target.Row
            c = Target.Column

            '塗りつぶし
            If r >= 2 And c >= 2 Then '項目名と日付部分は対象外
                Range(Cells(r, 1), Cells(r, c)).Interior.ColorIndex = 40 'ベージュ
                Range(Cells(1, c), Cells(r, c)).Interior.ColorIndex = 40 'ベージュ
                'Cells(1, c).Interior.ColorIndex = 40 'ベージュ ★タイトルだけに色を付けたい場合★
                'Cells(r, 1).Interior.ColorIndex = 40 'ベージュ ★タイトルだけに色を付けたい場合★
            End If
        End If

        'Application.EnableEvents = True 'SelectionChangeイベント発生する処理がある場合は記述
    End If
End Sub

Sub ProtectAllSheet()
    Dim curWs As Worksheet
    Dim ws As Worksheet

    Set curWs = ActiveSheet

    Application.ScreenUpdating = False
    For Each ws In Worksheets
        With ws
            .Activate
            .Range("A1").Select
            .EnableSelection = xlUnlockedCells
            .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        End With
    Next
    Application.ScreenUpdating = True

    ThisWorkbook.Protect Structure:=True, Windows:=False

    curWs.Activate
End Sub

Sub UnprotectAllSheet()
    Dim curWs As Worksheet
    Dim ws As Worksheet

    Set curWs = ActiveSheet

    For Each ws In Sheets
        With ws
            .EnableSelection = xlNoRestrictions
            .Unprotect
        End With
    Next

    ThisWorkbook.Unprotect

    curWs.Activate
End Sub