Sub ertert()
Dim fn As String, wsh As Worksheet, wb As Object
Dim r As Range, rr As Range, s As String, ss As String
Application.ScreenUpdating = False
ActiveSheet.Copy Before:=Sheets(1)
Set wsh = ActiveSheet: s = "ВСЕГО": ss = "Контрагент"
With wsh.UsedRange.Columns("B:B")
      Do
          Set r = .Find(s, lookat:=xlWhole)
          If Not r Is Nothing Then
              With .Cells(1, 1).Resize(r.Row)
                  Set rr = .Find(ss, lookat:=xlWhole)
                  If Not rr Is Nothing Then
                      fn = ThisWorkbook.Path & "\" & Replace(rr(1, 2), """", "") & "_" & rr(2, 2) & ".xls"
                      Set wb = Workbooks.Add
                      .EntireRow.Copy
                      wb.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll
                      wb.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
                      wb.SaveAs fn, xlNormal: DoEvents: wb.Close
                  End If
                  .EntireRow.Delete
              End With
          End If
      Loop Until r Is Nothing
End With
With Application
      .DisplayAlerts = False: wsh.Delete: .DisplayAlerts = True
      .ScreenUpdating = True
End With: Set wb = Nothing
End Sub