Option Explicit
    
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
    
Sub Управление_кнопками()
    ManageButtons (False) 'выключить кнопки
    ManageButtons (True) 'включить кнопки
End Sub

Private Sub ManageButtons(ByVal State As Boolean)
'https://support.microsoft.com/ru-ru/kb/177674/en-us

    Dim NumLockState As Boolean
    Dim ScrollLockState As Boolean
    Dim CapsLockState As Boolean
    
    Dim keys(0 To 255) As Byte
    GetKeyboardState keys(0)

    ' NumLock
    NumLockState = keys(VK_NUMLOCK)
    If NumLockState <> State Then
        keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0 'Simulate Key Press
        keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0 'Simulate Key Release
    End If
    
    ' CapsLock
    CapsLockState = keys(VK_CAPITAL)
    If CapsLockState <> State Then
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0 'Simulate Key Press
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0 'Simulate Key Release
    End If
    
    ' ScrollLock
    ScrollLockState = keys(VK_SCROLL)
    If ScrollLockState <> State Then
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0 'Simulate Key Press
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0 'Simulate Key Release
    End If
End Sub

Dim property As DocumentProperty

   .......
    Next i
    On Error GoTo 0

Sub Разделить_по_книгам()
    Dim oDic As Object, arrData(), arrSeparateItems(), arrTemp(), i&, n&, m&, k&

    If MsgBox("Разделить данные по книгам?", vbQuestion + vbYesNo, "Вопрос") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    arrData() = Range("A1").CurrentRegion.Value
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = LBound(arrData) To UBound(arrData)
        If Not oDic.exists(arrData(i, 5)) Then oDic.Add arrData(i, 5), arrData(i, 5)
    Next i
    arrSeparateItems() = oDic.items
    For n = LBound(arrSeparateItems) To UBound(arrSeparateItems)
        ReDim arrTemp(1 To UBound(arrData), 1 To UBound(arrData, 2))
        k = 0
        For i = LBound(arrData) To UBound(arrData)
            If arrData(i, 5) = arrSeparateItems(n) Then
                k = k + 1
                For m = LBound(arrData, 2) To UBound(arrData, 2)
                    arrTemp(k, m) = arrData(i, m)
                Next m
            End If
        Next i
        Workbooks.Add
        Range("A1").Resize(UBound(arrTemp), UBound(arrTemp, 2)).Value = arrTemp
        Columns("A:E").AutoFit
        Columns("B:B").HorizontalAlignment = xlLeft
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Right(arrSeparateItems(n), 3), xlExcel8
        ActiveWorkbook.Close SaveChanges:=True
    Next n
    Application.ScreenUpdating = True
    MsgBox "Данные разделены и сохранены в " & ThisWorkbook.Path & "\", vbInformation, "Конец"
End Sub