Sub CleanCells()
Dim lastrow, i As Integer
lastrow = ThisWorkbook.Sheets(1).UsedRange.Row + ThisWorkbook.Sheets(1).UsedRange.Rows.Count - 1
For i = 8 To lastrow
          ThisWorkbook.ActiveSheet.Cells(i, 5) = Null
          'ThisWorkbook.ActiveSheet.Cells(i, 7) = Null
     Next i
End Sub
Sub Ðàñ÷åò()
Dim FSO As Object
Dim lastrow, i As Integer
CleanCells
   Set FSO = CreateObject("Scripting.FileSystemObject")
   Search FSO.GetFolder(ThisWorkbook.Path)
   lastrow = ThisWorkbook.Sheets(1).UsedRange.Row + ThisWorkbook.Sheets(1).UsedRange.Rows.Count - 1
   
   'For i = 8 To lastrow
   'If (ThisWorkbook.ActiveSheet.Cells(i, 2) > 0) And (IsEmpty(ThisWorkbook.ActiveSheet.Cells(i, 6))) Then
    '      ThisWorkbook.ActiveSheet.Cells(i, 6) = 1
     '     ThisWorkbook.ActiveSheet.Cells(i, 6).NumberFormat = "0.00%"
      '    ThisWorkbook.ActiveSheet.Cells(i, 7) = "Îöåíî÷íàÿ âåäîìîñòü îòñóòñòâóåò"
     'End If
     'Next i
End Sub


 Sub Search(Fold As Object)
' Dim Fil As Object
  Dim wb As Workbook
Dim Sh As Worksheet
Dim i, j, lastrow As Integer
Dim curSotr As String
Dim curMark As Double
   On Error GoTo ErrHandle
  ' i = 8
j = 8
'MsgBox CurDir
'lastrow = ThisWorkbook.Sheets(1).UsedRange.Row + ThisWorkbook.Sheets(1).UsedRange.Rows.Count - 1

   'For Each SubFold In Fold.SubFolders
    ' Search SubFold
   'Next SubFold
   For Each Fil In Fold.Files
     If InStr(1, Fil.Name, ".xlsx", vbTextCompare) > 0 Then
      Set wb = Workbooks.Open(Fil.Path)
 Set Sh = wb.Sheets(1)
          Sh.Select
          curSotr = Sh.Cells(4, 4)
          For j = 8 To 60
          If ThisWorkbook.Sheets(1).Cells(j, 4) = curSotr Then
          ThisWorkbook.Sheets(1).Cells(j, 5) = Sh.Range("K10").Value
          ThisWorkbook.Sheets(1).Cells(j, 5).NumberFormat = "0.00%"
     End If
     Next j
   '  i = i + 1
     wb.Close
     End If
   Next Fil
   Exit Sub
ErrHandle:
   MsgBox "Нет доступа""" & Fold.Path & """"
   Err.Clear
End Sub