Option Explicit
'
' код добавить в стандартынй модуль (!) _НЕ_ Вашей книги со сводной таблицей
' (!) книга с Вашей сводной таблицей должна быть ЗАКРЫТА
' запускать Sub pr_itog2()
' в первом диалоге выбираете книгу с Вашей сводной
' второй и третий диалоги для задания границ обработки аналогичны Вашим 
'

' ********************************************************
' no comment
Private Sub AUXbefore()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .CalculateBeforeSave = False
    End With
End Sub

' ********************************************************
' no comment
Private Sub AUXafter()
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .CalculateBeforeSave = True
    End With
End Sub

' ********************************************************
' процедура обновления сводной
' (!) файл со сводной должен быть ЗАКРЫТ
Sub pr_itog2()
    ' заготовка строки соединения (! pre Excel 12)
    Const S_CN$ = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=No;IMEX=2';Data Source="
    ' имя первого листа во временном файле
    Const S_WS1$ = "TDSheet"
    ' имена листов сводного и с фактичексими данными
    Const S_WS_FORM$ = "Frms", S_WS_FACT$ = "fct"
    ' имена полей листа с фактическими данными
    Const S_PK$ = "CodPkz", S_UNIT$ = "nZFUbjt", S_SMM$ = "Itog"
    ' сторка с номерами подразделений на сводном листе
    Const L_FORM_UNITROW& = 2
    ' первая строка с данными на сводном листе
    Const L_FORM_FIRSTROW& = 7
    
    Dim cn As Object, wb As Object
    Dim scn$, SQLbase$, SQLpfx$, SQLsfx$, tmpFile$, s$
    
    Dim FC&, LC&, FR&, LR&
    Dim BLC&, BLR&
    Dim PK&, NMZFU&, SMM&
    
    Dim i&, k&, a
    
    Dim t!
    
    ' выбор книги со сводной
    s = Application.GetOpenFilename("Excel Files (*.xls), *.xls", , "План-факт")
    If s = "False" Then Exit Sub
    
    t = Timer '### for debug only
    
    Call AUXbefore
    
    ' открытие книги со сводной
    Set wb = Workbooks.Open(s, , True)
    
    ' структура листа с факт.данными
    With wb.Worksheets(S_WS_FACT)
        BLR = .Cells(1, 1).End(xlDown).Row
        BLC = .Cells(1, 1).End(xlToRight).Column
        PK = 0: NMZFU = 0: SMM = 0: k = 0
        For i = BLC To 1 Step -1
            If SMM = 0 Then
                If StrComp(.Cells(1, i).Value2, S_SMM) = 0 Then SMM = i: k = k + 1
            ElseIf NMZFU = 0 Then
                If StrComp(.Cells(1, i).Value2, S_UNIT) = 0 Then NMZFU = i: k = k + 1
            ElseIf PK = 0 Then
                If StrComp(.Cells(1, i).Value2, S_PK) = 0 Then PK = i: k = k + 1
            End If
            If k = 3 Then Exit For
        Next i
        If k <> 3 Then
        ' требуемые поля не найдены
            wb.Close False
            Set wb = Nothing
            MsgBox "fact data not found!", vbExclamation, "PR_ITOG2"
            Call AUXafter: Exit Sub
        End If
        
        ' текст запроса для заполнения временного файла
        SQLpfx = "select F" & PK & ",F" & NMZFU & ",sum(F" & SMM & ")"
        SQLpfx = SQLpfx & " from [" & S_WS_FACT & "$A2:" & .Cells(BLR, BLC).Address(0, 0)
        SQLpfx = SQLpfx & "] where F" & PK & ">'' group by F" & PK & ",F" & NMZFU
        
    End With 'wb.Worksheets(S_WS_FACT)
    
    ' FullName временного файла
    tmpFile = Environ$("TEMP") & "\tmp" & CLng(Date) & Int(Timer) & ".xls"
    
    ' структура сводного листа
    With wb.Worksheets(S_WS_FORM)
        FC = 0: LC = 0
'FC = 23: LC = 78                               '### debug

'### 2do check FC,LC values
        Do While FC = 0
            FC = InputBox("Введите номер первого столбца факта", "Первый столбец", 0)
        Loop
        Do While LC = 0
            LC = InputBox("Введите номер последнего столбца факта", "Последний столбец", 0)
        Loop
        
        FR = L_FORM_FIRSTROW: LR = .Cells(65535, 1).End(xlUp).Row
                
        ' заготовка текста запроса для обновления сводного листа
        SQLbase = "]) AS A,(SELECT F1 AS PK,F2 AS NMZFU,F3 AS SM"
        SQLbase = SQLbase & " FROM [" & S_WS1 & "$] in '" & tmpFile & "' 'Excel 8.0;HDR=No;IMEX=1') AS B"
        SQLbase = SQLbase & " WHERE B.PK=A.PK AND B.NMZFU="
        SQLbase = " AS ZZ FROM [" & S_WS_FORM & "$A" & FR & ":" & .Cells(LR, LC).Address(0, 0) & SQLbase
        
        ' заготовка текста запроса для очистки сводных данных перед обновлением
        s = " AS ZZ FROM [" & S_WS_FORM & "$A" & L_FORM_FIRSTROW & ":" & .Cells(LR, LC).Address(0, 0) & "] WHERE F1>'') SET ZZ=null"
        
        ' массив с номерами подразделений
        a = .Range(.Cells(L_FORM_UNITROW, FC), .Cells(L_FORM_UNITROW, LC)).Value
    End With 'wb.Worksheets(S_WS_FORM)
    
    ' строка соединения
    scn = S_CN & wb.FullName
    
    ' закрытие книги со сводной
    wb.Close False
    Set wb = Nothing
    
    ' создание и открытие соединения ADO
    Set cn = CreateObject("adodb.connection")
    cn.Open scn
    
    ' создание, заполнение и сохранение временной книги
    With Workbooks.Add
        With .Worksheets(1)
            .Name = S_WS1
            .Columns(1).NumberFormat = "@"
            cn.BeginTrans
            .Cells(1, 1).CopyFromRecordset cn.Execute(SQLpfx, , 1)
            cn.CommitTrans
        End With
        .SaveAs tmpFile
        .Close
    End With
    
    ' префикс и суффикс текста запроса для обновления сводного листа
    SQLpfx = "UPDATE (SELECT A.PK AS PKA,A.ZZ,B.SM FROM (SELECT F1 AS PK, F"
    SQLsfx = ") SET ZZ=SM WHERE PKA>''"
    
    ' обновление сводного листа
    cn.BeginTrans
    For i = 1 To UBound(a, 2)
    If a(1, i) > 0 Then
        k = FC + i - 1                                                      ' номер обрабатываемого столбца
        cn.Execute "UPDATE (SELECT F" & k & s, 0&, 1 Or &H80&               ' аналог ClearContents
        cn.Execute SQLpfx & k & SQLbase & a(1, i) & SQLsfx, 0&, 1 Or &H80&  ' обновление данных
    End If
    Next i
    cn.CommitTrans
    
    ' закрытие соединения ADO
    cn.Close
    Set cn = Nothing
    
    Erase a
    
    Call AUXafter
                
    ' удаление временного файла
    Kill tmpFile
                
    MsgBox "time expended: " & Int(Timer - t) & " sec", , "PR_ITOG2" '### for debug only
End Sub