'使用されていない表示形式を削除するマクロ(Excel95)

'開いているすべてのブックを対象とします。

'新規ブックのモジュールシートに以下のコードをコピーして
'MyDeleteNumberFormatマクロを実行してください。

Option Explicit

Const CF_TEXT = &H1
Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMEM As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMEM As Long) As Long
Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long


'クリップボードからテキストを取得する関数
Function GetClipboardText() As Variant
    Dim hglb As Long, lptstr As Long, iLength As Long, iRet As Long
    Dim sBuffer As String

    On Error GoTo err_1

    GetClipboardText = False

    'テキストデータかチェック
    If IsClipboardFormatAvailable(CF_TEXT) = 0 Then Exit Function

    'クリップボードのオープン
    If OpenClipboard(0) = 0 Then Exit Function

    'クリップボードのグローバルメモリハンドルを取得
    hglb = GetClipboardData(CF_TEXT)
    If hglb = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    'グローバルメモリのロック
    lptstr = GlobalLock(hglb)
    If lptstr = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    '文字列の長さを取得
    iLength = lstrlen(lptstr)
    If iLength = 0 Then
        GetClipboardText = ""
        iRet = GlobalUnlock(hglb)
        iRet = CloseClipboard()
        Exit Function
    End If

    '文字列変数へコピー
    sBuffer = String(iLength, " ")
    If lstrcpy(sBuffer, lptstr) <> 0 Then
        GetClipboardText = sBuffer
    End If

    'グローバルメモリのロック解除
    iRet = GlobalUnlock(hglb)

    'クリップボードのクローズ
    iRet = CloseClipboard()
    Exit Function

err_1:
    If hglb <> 0 Then iRet = GlobalUnlock(hglb)
    iRet = CloseClipboard()
End Function


'使用されていない表示形式を削除するマクロ
Sub MyDeleteNumberFormat()
    Dim oRange_Output As Range
    Dim oBook As Workbook
    Dim sBookName1 As String, sBookName2 As String

    Set oRange_Output = Workbooks.Add(xlWorksheet).Worksheets(1).Cells(2, 1)
    oRange_Output.Worksheet.Cells.Clear
    oRange_Output.Offset(-1, 0).Resize(1, 3).Value _
        = Array("ブック", "状態", "表示形式")
    sBookName1 = ThisWorkbook.Name
    sBookName2 = oRange_Output.Worksheet.Parent.Name
    For Each oBook In Workbooks
        If (oBook.Name <> sBookName1) And (oBook.Name <> sBookName2) Then
            oBook.Activate
            MyDeleteNumberFormat2 oRange_Output
        End If
    Next
    With oRange_Output.Worksheet
        .Columns.AutoFit
        .Parent.Activate
    End With
End Sub

Sub MyDeleteNumberFormat2(ByRef oRange_Output As Range)
    Dim oBook As Workbook
    Dim oSheet As Object, r As Range
    Dim sArray() As String, sArray2() As String
    Dim bUsed() As Boolean
    Dim i As Integer, iCount As Integer
    Dim sBookName1 As String

    Set oBook = ActiveWorkbook
    sBookName1 = oBook.FullName

    '保護シートがある場合は削除できないので中断する
    For Each oSheet In oBook.Sheets
        If TypeName(oSheet) = "Worksheet" Then
            If oSheet.ProtectContents Then
                oRange_Output.Cells(1, 1).Value = "'" & sBookName1
                oRange_Output.Cells(1, 2).Value = "保護"
                Set oRange_Output = oRange_Output.Offset(1)
                Exit Sub
            End If
        End If
    Next

    'ユーザ定義表示形式をダイアログボックスから取得
    If Not MyGetNumberFormat(sArray(), iCount) Then
        oRange_Output.Cells(1, 1).Value = "'" & sBookName1
        oRange_Output.Cells(1, 2).Value = "エラー"
        Set oRange_Output = oRange_Output.Offset(1)
        Exit Sub
    End If

    If iCount = 0 Then
        oRange_Output.Cells(1, 1).Value = "'" & sBookName1
        oRange_Output.Cells(1, 2).Value = "なし"
        Set oRange_Output = oRange_Output.Offset(1)
        Exit Sub
    End If

    'NumberFormatへ変換
    ReDim sArray2(1 To iCount)
    With oRange_Output.Worksheet.Cells(1, 5)
        For i = 1 To iCount
            .NumberFormatLocal = sArray(i)
            sArray2(i) = .NumberFormat
        Next
        .Clear
    End With

    '使用フラグ配列の作成
    ReDim bUsed(1 To iCount)
    For i = 1 To iCount
        bUsed(i) = False
    Next

    '使用されている表示形式を調べる
    For Each oSheet In oBook.Worksheets
        For Each r In oSheet.UsedRange.Cells
            If SimpleSearchString(r.NumberFormat, _
                    sArray2(), iCount, i) Then
                bUsed(i) = True
            End If
        Next
    Next

    '削除とログ出力
    For i = 1 To iCount
        oRange_Output.Cells(1, 1).Value = "'" & sBookName1
        oRange_Output.Cells(1, 3).Value = "'" & sArray(i)
        If bUsed(i) Then
            oRange_Output.Cells(1, 2).Value = "使用"
        Else
            On Error Resume Next
            oBook.DeleteNumberFormat sArray2(i)
            If Err = 0 Then
                oRange_Output.Cells(1, 2).Value = "削除"
            Else
                oRange_Output.Cells(1, 2).Value = "削除不可"
            End If
            On Error GoTo 0
        End If
        Set oRange_Output = oRange_Output.Offset(1)
    Next
End Sub


'ユーザ定義表示形式をダイアログボックスから取得する関数
Function MyGetNumberFormat(ByRef sArray() As String, _
        ByRef iCount As Integer) As Boolean
    Dim sLastFormat As String, sFormat As String
    Dim i As Integer, iUpCount As Integer

    iCount = 0
    If ActiveSheet.ProtectContents And _
            (TypeName(ActiveSheet) <> "Module") Then
        MyGetNumberFormat = False
        Exit Function
    End If
    sLastFormat = "[h]:mm:ss"
    SendKeys "%c{END}%t{TAB}{END}+{TAB}^c{ESC}"
    Application.Dialogs(xlDialogDeleteFormat).Show
    sFormat = GetClipboardText()
    iUpCount = 1
    Do While sFormat <> sLastFormat
        If Not SimpleSearchString(sFormat, sArray(), iCount, i) Then
            iCount = iCount + 1
            ReDim Preserve sArray(1 To iCount)
            sArray(iCount) = sFormat
        End If
        SendKeys "%c{END}%t{TAB}{END}{UP " & iUpCount & "}+{TAB}^c{ESC}"
        Application.Dialogs(xlDialogDeleteFormat).Show
        sFormat = GetClipboardText()
        iUpCount = iUpCount + 1
    Loop
    MyGetNumberFormat = True
End Function

Function SimpleSearchString(s As String, sArray() As String, _
    iCount As Integer, ByRef iIndex As Integer) As Boolean
    Dim i As Integer
    For i = 1 To iCount
        If StrComp(s, sArray(i), 1) = 0 Then
            iIndex = i
            SimpleSearchString = True
            Exit Function
        End If
    Next
    SimpleSearchString = False
End Function


'アクティブブックのユーザ定義表示形式の一覧を作成するマクロ
Sub MyGetNumberFormat_Test()
    Dim sArray() As String, sBookName As String
    Dim i As Integer, iCount As Integer
    sBookName = ActiveWorkbook.FullName
    MyGetNumberFormat sArray(), iCount
    Workbooks.Add xlWorksheet
    Cells(1, 1).Value = "'" & sBookName & " のユーザ定義表示形式"
    For i = 1 To iCount
        Cells(i + 1, 1).Value = "'" & sArray(i)
    Next
End Sub