Private Sub CommandButton1_Click()
Dim cell As Range
Dim value As Double
numCell = 2
Set rgData = Range("B2:B11")
s = Replace(TextBox1.value, ".", ",")
value = CDbl(s)
Set myList = Worksheets.Add(After:=Worksheets(Worksheets.Count))
myList.Cells(1, 1) = Sheets("Лист1").Cells(1, 1)
myList.Cells(1, 2) = Sheets("Лист1").Cells(1, 2)
For Each cell In rgData
If cell.value > value Then
myList.Cells(numCell, 1) = Sheets("Лист1").Cells(cell.Row, cell.Column - 1)
myList.Cells(numCell, 2) = Sheets("Лист1").Cells(cell.Row, cell.Column)
numCell = numCell + 1
End If
Next
UserForm1.Hide
End Sub
Sub RRR()
Shapka = "B2:C3" ' Область шапки
RFil = "C3" ' Ячейка с фильтром по цене
RName = "B3" ' Ячейка с шапкой с названиями (товар обязательно должен иметь название)
Info = "C1" ' Ячейка куда запишется значение фильтра в выходной форме
NewList = "Отобрано" ' Имя листа, если выборка делается на один и тот же лист
R1 = Mid(Shapka, 1, InStr(1, Shapka, CStr(Range(Shapka).Row) + ":") - 1) + "1"
ACol = Replace(Shapka, CStr(Range(Shapka).Row) + ":", ":")
FRow = Range(Shapka).Cells(Range(Shapka).Count).Row
ACol = Replace(ACol, CStr(FRow), "")
iFil = 1 + Range(RFil).Column - Range(Shapka).Column ' Номер столбца в шапке для фильтра
iReestr = ActiveSheet.Index
CGod = InputBox("Введите цену товара", "Отбор товара не более указанной цены")
If CGod = "" Then Exit Sub
If Not IsNumeric(CGod) Then
MsgBox "Введенное значение цены" + vbCrLf + vbCrLf + """" + CGod + """" + vbCrLf + vbCrLf + "не число"
Exit Sub
End If
God = CCur(CGod)
If God < 0 Then
MsgBox "Введенное значение цены" + vbCrLf + vbCrLf + """" + CGod + """" + vbCrLf + vbCrLf + "не корректно"
Exit Sub
End If
'NewList = CGod ' Закомментировать, чтобы выборка делалась на один лист
' Иначе выборка для каждой цены будет на отдельном листе со значением цены
Application.DisplayAlerts = False
On Error Resume Next
Sheets(NewList).Delete
On Error GoTo 0
Application.DisplayAlerts = True
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = NewList
iNew = ActiveSheet.Index
Sheets(iReestr).Select
Columns(ACol).Copy
Sheets(iNew).Select
Range(R1).Select
Range(R1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets(iReestr).Select
AFiltr = Replace(ACol, ":", CStr(Range(Shapka).Row + 1) + ":") + CStr(Range(RName).End(xlDown).Row)
ActiveSheet.Range(AFiltr).AutoFilter Field:=iFil, Criteria1:="<=" + Replace(CGod, ",", "."), Operator:=xlAnd
Columns(ACol).Copy
Sheets(iNew).Select
Range(R1).Select
ActiveSheet.Paste
Sheets(iReestr).Select
Selection.AutoFilter
Range(R1).Select
Sheets(iNew).Select
Range(Info) = "<=" + CGod
Range(Info).Select
End Sub
Если Вы уже зарегистрированы на Портале - войдите в систему, если Вы еще не регистрировались - пройдите простую процедуру регистрации.