Sub СохранитьРеестрПродаж()
On Error Resume Next
Application.DisplayAlerts = False
Dim bookconst As Workbook
Set bookconst = Workbooks(ActiveWorkbook.Name)
Application.ScreenUpdating = False
ActiveSheet.Copy
Dim sName, fAdres As Variant
sName = ActiveSheet.Name
fAdres = bookconst.Path
If Len(Dir(fAdres & "\" & sName, vbDirectory)) = 0 Then
MkDir fAdres & "\" & sName
End If
ActiveWorkbook.SaveAs Filename:=fAdres & "\" & sName & "\" & sName & "_" & Date & ".xlsx"
Application.ScreenUpdating = True
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub

Sub УдалитьСтрокуТорг()
Dim lr2 As Long, i As Long, k As Long
Application.ScreenUpdating = False
k = Application.WorksheetFunction.CountIf(Range("Torg[a]"), "a")
If k = 0 Then
MsgBox "Не выбрано ни одной позиции!", vbCritical, "Ошибка удаления"
Exit Sub
End If
    lr2 = Cells(Rows.Count, 5).End(xlUp).Row
    For i = lr2 To 5 Step -1
        If Cells(i, 2) = "a" Then
            Range("B" & i & ":R" & i).EntireRow.Delete
            End If
    Next i
    Range("E7").Select
    
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Initialize()
   X = Range("Sclad[[Наименование]:[Остаток]]").Value
   Me.ListBox1.List = X
   TextBox1.SetFocus
End Sub

Private Sub TextBox1_Change()
Dim i As Long, s As String, txt As String, lt As Long

txt = TextBox1.Text: lt = Len(txt)
For i = 1 To UBound(X)    ' поиск по первым буквам (Search by first letter)
   If txt = Mid(X(i, 1), 1, lt) Then s = s & "~" & X(i, 1)
Next i
Me.ListBox1.List = Split(Mid(s, 2), "~")
If lt = 0 Then ListBox1.Clear

End Sub

=ЕСЛИ([@Наименование]="";"";СТРОКА(B1)) 

=ЕСЛИ([@Наименование]=";";СТРОКА(B1))