Private Sub СуммаОбщая()
'Подсчет суммы по всем файлам
Dim fs As New FileSystemObject
Dim fld As Folder
Dim fls As Files
Dim fl As File
Dim s As String
Dim flname As String
Dim fln As String
s = Trim(TextBox20.Text)
t = Val(TextBox26.Text)
If t =  0  Then
MsgBox "Укажите смещение ячейки с суммой относительно Итого (СуммаСтолбец справа)"
Exit Sub
End If
If s = "" Then
MsgBox "Укажите каталог, в котором находятся файлы"
Exit Sub
End If
If Not fs.FolderExists(s) Then
MsgBox "Такой папки нет"
Exit Sub
End If
Worksheets("Сумма").Activate
Application.ScreenUpdating = False
Set fld = fs.GetFolder(s)
Set fls = fld.Files
n1 = fls.Count
ReDim su( 1  To n1,  1  To  2 )

n11 =  0 
For Each fl In fls
n11 = n11 +  1 
flname = fl.Name
fln = Mid(flname,  1 , Len(flname) -  4 )
Workbooks.Open s & "\" & flname
Set rr = ActiveWorkbook.Sheets( 1 ).Range("A:E").Find(what:="Итого", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlColumns)
If LCase(Left(rr.Value,  5 )) <> "итого" Then
Do While LCase(Left(rr.Value,  5 )) <> "итого"
Set rr = ActiveWorkbook.Sheets( 1 ).Range("A:E").FindNext(rr)
Loop
End If
Set rrr = rr.Offset( 0 , t)
su(n11,  1 ) = fln
su(n11,  2 ) = rrr.Value
ActiveWorkbook.Close
Next

ActiveWorkbook.Worksheets("Сумма").Columns( 1 ).Insert
ActiveWorkbook.Worksheets("Сумма").Columns( 1 ).Insert
ActiveWorkbook.Worksheets("Сумма").Columns( 1 ).Insert
Set r = ActiveWorkbook.Worksheets("Сумма").Range("A1")
Set r = r.Resize(UBound(su,  1 ) +  2 ,  2 )
r.Font.Name = "Courier New"
r.Font.Size =  11 
Set rr = r.Rows( 1 )
rr.Font.Bold = True
rr.Font.Size =  12 
rr.Cells( 1 ,  1 ).Value = s & "\"
rr.Cells( 1 ,  2 ).Value = "Сумма"

Set rr = r.Rows(r.Rows.Count)
rr.Font.Bold = True
rr.Font.Size =  12 
rr.Cells( 1 ,  1 ).Value = "ИТОГО:"
rr.Cells( 1 ,  2 ).NumberFormat = "0.00"

Set rrr = r.Offset( 1 ,  0 ).Resize(r.Rows.Count -  2 ,  2 )
rrr.Columns( 1 ).NumberFormat = "@"
rrr.Columns( 2 ).NumberFormat = "0.00"
rrr.Value = su

rr.Cells( 1 ,  2 ).Value = Application.WorksheetFunction.Sum(rrr.Columns( 2 ))
r.Columns.AutoFit
Application.ScreenUpdating = True
Erase su
Set r = Nothing
Set rr = Nothing
Set rrr = Nothing
MsgBox "Готово "
End Sub