Option Explicit
Dim arr

Sub Векселя()
     Application.ScreenUpdating = False
     'Dim K As Long, s As String
     'For K = ThisWorkbook.Worksheets.Count To 1 Step -1
     'With ThisWorkbook.Worksheets(K)
     'Worksheets(K).Activate
     Dim l As Integer, m, n As String
     'l = 15
     l = ActiveSheet.Index
     m = "АБДДС.xlsb"
     Dim e, d As Workbook
     Sheets(l).Select
     Set e = ThisWorkbook.ActiveSheet

     Dim pthh, pth$: Application.ScreenUpdating = False
     pthh = ThisWorkbook.Path & "\"
     Set d = Workbooks.Open("" & pthh & m, UpdateLinks:=0)
     Sheets(l).Select
     Dim lLastRow As Long
     Dim lLastCol As Long
     lLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
     lLastCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
     n = d.Sheets(l).Name
     'd.Close saveChanges:=False
     e.Activate
     Sheets(l).Select
     e.Name = n
     Cells.Select
     Selection.Delete Shift:=xlUp

     pth = ThisWorkbook.Path & "\[": arr = Empty
     Dim z As Variant, f As String, i&, j&    'z(1 To 33, 1 To 10)кол-во первый диапазон рядов, второй колонок
     z = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
     f = Dir(ThisWorkbook.Path & "\" & "*.xls*", vbNormal)
     Do While f <> ""
         If f <> ThisWorkbook.Name Then
             [a1].Formula = "=Toarr('" & pth & f & " ]" & Sheets(l).Name & "'! R1C1:R" & lLastRow & "C" & lLastCol & ")"
             For i = 1 To UBound(z, 1)    'ряды
                 For j = 1 To UBound(z, 2)    'колонки
                     'If IsError(arr(i, j)) Then
                     If arr(i, j) = "" Then
                         z(i, j) = z(i, j)
                     Else
                         If IsNumeric(arr(i, j)) Then
                             z(i, j) = z(i, j) + arr(i, j)
                         Else
                             z(i, j) = arr(i, j)
                             'End If
                         End If
                     End If
                 Next j
             Next i
         End If
         f = Dir()
     Loop
     e.Activate: Range(Cells(1, 1), Cells(lLastRow, lLastCol)).Value = z: [a1] = Empty

     Dim eCell As Range
     Set eCell = Range(Cells(1, 1), Cells(lLastRow, lLastCol))
     d.Activate
     'Set d = Workbooks.Open("" & pthh & m, UpdateLinks:=0)
     'Sheets(l).Select
     Dim dCell As Range
     Set dCell = Range(Cells(1, 1), Cells(lLastRow, lLastCol))

     d.Worksheets(l).Activate
     With dCell
         'Do While dCell < Range(Cells(1, 1), Cells(lLastRow + 1, lLastCol + 1))
         For i = 1 To lLastRow    'ряды
             For j = 1 To lLastCol    'колонки
                 'For Each dCell In .Range(Cells(1, 1), Cells(lLastRow, lLastCol))

                 If dCell(i, j).Locked = False Then
                     If dCell(i, j).Value >= "0" Then _
                        dCell(i, j).Value = ""
                     If dCell(i, j).Value <= "0" Then _
                        dCell(i, j).Value = ""
                 Else
                     If dCell(i, j).Locked = True Then
                         If dCell(i, j) = xlFormula Then
                             eCell(i, j).Formula = dCell(i, j).Formula
                         End If
                     End If
                 End If
             Next j
         Next i
         'Loop
     End With

     d.Activate: Range(Cells(1, 1), Cells(lLastRow, lLastCol)).Copy
     e.Activate
     Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
     Cells(1, 1).PasteSpecial Paste:=xlPasteFormulas, SkipBlanks:=True
     Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
     e.Activate: Cells.Replace What:="[АБДДС.xlsb]", replacement:="", LookAT:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

     e.Activate: Range("W1").Clear
     d.Close saveChanges:=False
     Range("A1").Select
     Application.ScreenUpdating = True
     'End With
     ' Next
End Sub

Function ToArr(ExtData)
     arr = ExtData
End Function