Sub Разделить_по_книгам()
    Dim oDic As Object, arrData(), arrSeparateItems(), arrTemp(), i&, n&, m&, k&
    Dim arrTemp1() '.........Правка
  
    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, 1)) Then oDic.Add arrData(i, 1), arrData(i, 1)
    Next i
    arrSeparateItems() = oDic.items
    For n = LBound(arrSeparateItems) + 1 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, 1) = 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
                ReDim arrTemp1(1 To 1, 1 To UBound(arrData, 2)) '.........
                For m = 1 To UBound(arrData, 2) '........
                    arrTemp1(1, m) = arrData(1, m) '..........
                Next m '..........
        Range("A1").Resize(1, UBound(arrData, 2)).Value = arrTemp1 '.........
        Range("A2").Resize(UBound(arrTemp), UBound(arrTemp, 2)).Value = arrTemp
        Columns("A:E").AutoFit
        Columns("B:G").HorizontalAlignment = xlLeft
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Right(arrSeparateItems(n), 10), xlExcel8
        ActiveWorkbook.Close SaveChanges:=True
    Next n
    Application.ScreenUpdating = True
    MsgBox "Данные разделены и сохранены в " & ThisWorkbook.Path & "\", vbInformation, "Конец"
End Sub