'=========================================================
' Author: nerv | E-mail: nerv-net@yandex.ru
' Last Update: 10/06/2011 | Яндекс.Деньги: 41001156540584
'=========================================================
Option Explicit '\Обязательное объявление переменных на уровне модуля\

Public Function LoadButtonOpenBookAndCalculate() '\Добавить кнопку на панель инструментов "Форматирование"\
Dim pushLC As Object '\Объявляем переменную нового инструмента на панели задач\
Set pushLC = Application.CommandBars("Formatting").Controls.Add(Type:=msoControlButton, Temporary:=True) '\Добавляем новый элемент на панель\

With pushLC '\Настраиваем элемент\
.BeginGroup = True '\Добавить разделитель\
.Style = msoButtonAutomatic '\Кнопка содержит рисунок\
.Caption = "Открыть книгу для калькуляции: сложить текущие значения с значениями из выбранной книги" '\Имя/всплывающая подсказка\
.OnAction = "OpenBookForCalcSumValue" '\Назначить макрос\
.FaceId = 283 '\Иконка калькулятора\
End With

Set pushLC = Nothing '\Очищаем память\
End Function

'==========================================================================
' Открыть книгу для добавления из нее значений к текущим, путем сложения
' Last Update: 10/06/2011
'==========================================================================
Public Function OpenBookForCalcSumValue()
Dim PathAndNameBook As String, NameBook As String, BookList As Object, RangeValue(4) As Object, objCell As Object, k As Integer, q As Byte
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

On Error GoTo ErrMsgAndQuit '\При возникновении ошибки выдать сообщение и завершить работу\
PathAndNameBook = Application.GetOpenFilename(FileFilter:="Книга Excel (*.xls), *.xls", Title:="Выберите книгу из которой необходимо перенести данные", MultiSelect:=False) '\Записать в переменную полный путь + имя файла\
Workbooks.Open Filename:=PathAndNameBook, ReadOnly:=True '\Открыть книгу только для чтения\

Do
k = k + 1 '\Наращиваем значение переменной\
Loop Until Mid(PathAndNameBook, Len(PathAndNameBook) - k, 1) = "\" '\Первый слеш справа\

NameBook = Right(PathAndNameBook, k) '\Получить только имя книги\
Set BookList = Workbooks(NameBook).Sheets("р6.5") '\Первый лист открытой книги\
ThisWorkbook.Activate '\Сделать активной текущую книгу\

With BookList '\C листом открытой книги\
Set RangeValue(0) = .Range("G10:W446")
End With

For q = 0 To 0 '\По массиву с диапазонами данных\

For Each objCell In RangeValue(q) '\Ячейка диапазона\

With objCell '\С ячейкой\
If .HasFormula = False And Range(.Address).HasFormula = False Then '\Если ячейки не содержат формул\

If .Locked = False And Range(.Address).Locked = False Then '\Ячейка не защищена?\
L1:
If IsNumeric(.Value) = True Then '\Число?\

Range(.Address) = Range(.Address) + .Value '\Перенести данные сложив их с ячейкой-получателем\

Else

Application.ScreenUpdating = True
Workbooks(NameBook).Activate '\Показать книгу\
.Activate '\Показать ячейку с ошибкой\
.Value = InputBox("Значение в ячейке не является числом. Введите новое в этом окне и нажмите Enter" & Chr(10) & Chr(10) & "При нажатии Cancel значение она будет пропущена", "Ошибка в ячейке " & .Address, .Value)
ThisWorkbook.Activate '\На стартовую книгу\
Application.ScreenUpdating = False
GoTo L1

End If
End If

End If
End With

Next
Next

Workbooks(NameBook).Close SaveChanges:=False '\Не сохранять, закрыть\

ErrMsgAndQuit:
If Err = 9 Then MsgBox Prompt:="Книга указана неправильно", Buttons:=vbCritical, Title:="Ошибка"

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

PathAndNameBook = Empty
NameBook = Empty
Set BookList = Nothing
Set objCell = Nothing
Erase RangeValue()
k = 0
q = 0
End Function