Отправляет email-рассылки с помощью сервиса Sendsay

RFpro.ru: Пакет Microsoft Office

Подписаться Бесплатная «Золотая» новостная рассылка . Подписчиков 2.040 RSS
←   Июнь 2019   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30


За последние 60 дней ни разу не выходила


Сайт рассылки: http://rusfaq.ru
Открыта: 03-03-2006

Автор
Калашников О.А.

Статистика

2.040 подписчиков
0 за неделю
←   Все выпуски   →

RFpro.ru: Пакет Microsoft Office


РАССЫЛКИ ПОРТАЛА RFPRO.RU

Лучшие эксперты в разделе

solowey
Статус: Практикант
Рейтинг: 356
∙ повысить рейтинг » 		Megaloman
Статус: Академик
Рейтинг: 198
∙ повысить рейтинг » 		CradleA
Статус: Профессор
Рейтинг: 107
∙ повысить рейтинг »

∙ Пакет MSOffice

Номер выпуска:999
Дата выхода:02.06.2019, 13:45
Администратор рассылки:Megaloman (Академик)
Подписчиков / экспертов:30 / 29
Вопросов / ответов:1 / 2

Консультация # 195740: Всем Здравствуйте! Прошу помощи, необходимо составить программу в VBA Excel c помощью макросов. Задание такое: Составить список товаров, стоимость которых больше заданной. То есть будет таблица с такими столбцами "Название товара" и "Стоимость". По нажатию кнопки нужно чтобы появлялось окно с вводом цены...

Консультация # 195740:

Всем Здравствуйте! Прошу помощи, необходимо составить программу в VBA Excel c помощью макросов. Задание такое: Составить список товаров, стоимость которых больше заданной. То есть будет таблица с такими столбцами "Название товара" и "Стоимость". По нажатию кнопки нужно чтобы появлялось окно с вводом
цены, и программа на другом листе должна создать такую же таблицу , только с теми товарами с ценовой категорией меньше заданной. Заранее спасибо!

Дата отправки: 28.05.2019, 13:22
Вопрос задал: Sashasss3 (Посетитель)
Всего ответов: 2
Страница онлайн-консультации »

Консультирует solowey (Практикант):

Здравствуйте, Sashasss3
Вот пример кода:

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

Во вложение пример.

Консультировал: solowey (Практикант)
Дата отправки: 29.05.2019, 10:21
Прикреплённый файл: посмотреть » [18.3 кб]
Рейтинг ответа:

НЕ одобряю 0 одобряю!

Консультирует Megaloman (Академик):

Здравствуйте, Sashasss3!
Мой вариант решения: таблица ya19052920.xlsm (38.8 кб)
Макрос:

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

Консультировал: Megaloman (Академик)
Дата отправки: 29.05.2019, 20:13
Рейтинг ответа:

НЕ одобряю 0 одобряю!

Оценить выпуск | Задать вопрос экспертам

главная страница  |  стать участником  |  получить консультацию
техническая поддержка

Дорогой читатель!
Команда портала RFPRO.RU благодарит Вас за то, что Вы пользуетесь нашими услугами. Вы только что прочли очередной выпуск рассылки. Мы старались. Пожалуйста, оцените его. Если совет помог Вам, если Вам понравился ответ, Вы можете поблагодарить автора - для этого в каждом ответе есть специальные ссылки. Вы можете оставить отзыв о работе портале. Нам очень важно знать Ваше мнение. Вы можете поближе познакомиться с жизнью портала, посетив наш форум, почитав журнал, который издают наши эксперты. Если у Вас есть желание помочь людям, поделиться своими знаниями, Вы можете зарегистрироваться экспертом. Заходите - у нас интересно!
МЫ РАБОТАЕМ ДЛЯ ВАС!
В избранное