If fso.folderexists(Папка) Then

For Each vSubFolder In fso.getFolder(Папка).SubFolders

Имя = Dir(Папка & "*.xls")

Set objFolder = objFSO.GetFolder(sPath)

Sub uble_rem2()
   Dim Папка$, Имя$
   Dim wb As Workbook
   Dim smallrng As Range
   Dim WS_Count As Integer
   Dim lRow As Long
Dim T As Integer
 
   Application.ScreenUpdating = False
  
   Папка = "C:\TMP1" & "\"
   
      Имя = Dir(Папка & "*.xls")
      
   Do While Имя <> ""
   file = Папка & Имя
   Workbooks.Open file, ReadOnly:=False, IgnoreReadOnlyRecommended:=True, UpdateLinks:=True
 WS_Count = ActiveWorkbook.Worksheets.Count
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:Z" & lRow).RemoveDuplicates Array(1, 2, 26)
 
wb.Sheets(1).Activate
    ActiveWorkbook.Save
    ActiveWorkbook.Close
      Имя = Dir
   Loop
   Application.ScreenUpdating = True
End Sub

Sub sum()
Dim LastRow As Long
Dim i As Long
Dim j As Long
Dim s As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
       s = 0
       j = i
              Do While Cells(j, 1) = Cells(i, 1)
                  s = s + Cells(j, 2)
        j = j + 1
        If i = LastRow + 1 Then GoTo en
         Loop
                 Cells(j - 1, 4) = s
             Next i
en:
End Sub

On Error Resume Next

Sheets(1).Cells(i, 33) = Sheets(1).Cells(i, 33) +Application.Index(Sheets(3).Range("K4:K" & j), Application.Match(Range("A" & i).Value, Sheets(3).Range("L4:L" & j), 0))

On Error Resume Next

Sheets(1).Cells(i, 33) = Sheets(1).Cells(i, 33) +Application.Index(Sheets(3).Range("K4:K" & j), Application.Match(Range("A" & i).Value, Sheets(3).Range("L4:L" & j), 0))

s = Application.Index(Sheets(3).Range("K4:K" & j), Application.Match(Range("A" & i).Value, Sheets(3).Range("L4:L" & j), 0))


If s = "#Н/Д" Then
Sheets(1).Cells(i, 33) = Sheets(1).Cells(i, 33)
Else
Sheets(1).Cells(i, 33) = Sheets(1).Cells(i, 33) + s
End If

If wsSh.name <> "Лист1" Or wsSh.name Like "*.17" Or wsSh.name Like "*.2017" Then

If wsSh.name <> "Лист1" And Not wsSh.name Like "*.16" Then

If wsSh.name <> "Лист1" And wsSh.name > "30.12.16" Then

Sub a_test_a111()
Application.ScreenUpdating = 0
Dim lastrow As Long
Dim wsSh As Worksheet
Dim shRes As Worksheet
Dim lr As Long, i As Long, j As Long, r As Long
    Dim arrSrc(), arrRes()
Set wsSh = Worksheets("04.01.17")
 Set shRes = Worksheets("Лист6")
    For Each wsSh In ActiveWorkbook.Worksheets
        wsSh.Activate
        lastrow = 0
    lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        r = 0
    arrSrc() = wsSh.Range("A2:F" & lastrow).Value
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 6)
    For i = 2 To UBound(arrSrc, 1)
          If arrSrc(i, 3) = "" Then
            r = r + 1
            For j = 1 To 6
                arrRes(r, j) = arrSrc(i, j)
            Next
        End If
    Next
         If r = 0 Then
        GoTo endm
    End If
    
    Sheets("Лист6").Activate
    iRow = shRes.Cells(Rows.Count, 1).End(xlUp).Row + 1
    shRes.Cells(iRow, 1).Resize(r, 6).Value = arrRes()
    shRes.Activate
Next wsSh
 Application.ScreenUpdating = 1
endm:
    Erase arrSrc, arrRes
End Sub