Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Отображение результат отбора с заданным порядком - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Отображение результат отбора с заданным порядком (Макросы/Sub)
Отображение результат отбора с заданным порядком
AVI Дата: Среда, 17.10.2018, 07:44 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 453
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
Добрый день!
Мне нужно, что бы из таблицы Перечень_накл в столбец F перенеслись названия, которые соответствуют периоду, указанному в ячейке D1. Причем, перенеслись с учетом пордяка, который отражен в диапазоне B2:B15
В столбцах I и j отражены результаты, которые должны получиться для сентября и октября
К сообщению приложен файл: _Microsoft_Exce.xlsm(9.8 Kb)
 
Ответить
СообщениеДобрый день!
Мне нужно, что бы из таблицы Перечень_накл в столбец F перенеслись названия, которые соответствуют периоду, указанному в ячейке D1. Причем, перенеслись с учетом пордяка, который отражен в диапазоне B2:B15
В столбцах I и j отражены результаты, которые должны получиться для сентября и октября

Автор - AVI
Дата добавления - 17.10.2018 в 07:44
_Boroda_ Дата: Среда, 17.10.2018, 11:34 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13514
Репутация: 5529 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Вроде вот так работает
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    d0_ = Cells(2, 4)
    If Not IsDate(d0_) Then Exit Sub
    d_ = Format(d0_, "m\/d\/yyyy")
    rd_ = Cells(Rows.Count, 4).End(3).Row
    If rd_ > 2 Then
        Cells(3, 4).Resize(rd_).ClearContents
    End If
    With ActiveSheet
        With .ListObjects("Перечень_накл").Range
            .AutoFilter Field:=2, Operator:=xlFilterValues, Criteria2:=Array(1, d_)
            .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy Cells(3, 4)
            .AutoFilter Field:=2
        End With
        rd_ = Cells(Rows.Count, 4).End(3).Row
        If rd_ > 2 Then
            Application.AddCustomList ListArray:=Range("B3:B15")
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("D3:D" & rd_), CustomOrder:=Application.CustomListCount
                .SetRange Range("D2:D" & rd_)
                .Apply
            End With
            Application.DeleteCustomList ListNum:=Application.CustomListCount
        End If
    End With
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]
Файл не прикладываю - Excel вылетел, файл не сохранился, макрос восстановил по памяти (кстати, проверьте - мог где-нибудь накосячить)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеВроде вот так работает
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    d0_ = Cells(2, 4)
    If Not IsDate(d0_) Then Exit Sub
    d_ = Format(d0_, "m\/d\/yyyy")
    rd_ = Cells(Rows.Count, 4).End(3).Row
    If rd_ > 2 Then
        Cells(3, 4).Resize(rd_).ClearContents
    End If
    With ActiveSheet
        With .ListObjects("Перечень_накл").Range
            .AutoFilter Field:=2, Operator:=xlFilterValues, Criteria2:=Array(1, d_)
            .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy Cells(3, 4)
            .AutoFilter Field:=2
        End With
        rd_ = Cells(Rows.Count, 4).End(3).Row
        If rd_ > 2 Then
            Application.AddCustomList ListArray:=Range("B3:B15")
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("D3:D" & rd_), CustomOrder:=Application.CustomListCount
                .SetRange Range("D2:D" & rd_)
                .Apply
            End With
            Application.DeleteCustomList ListNum:=Application.CustomListCount
        End If
    End With
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]
Файл не прикладываю - Excel вылетел, файл не сохранился, макрос восстановил по памяти (кстати, проверьте - мог где-нибудь накосячить)

Автор - _Boroda_
Дата добавления - 17.10.2018 в 11:34
AVI Дата: Среда, 17.10.2018, 12:48 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 453
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
_Boroda_, Не работает. Я пытался подправить как мог, но все равно не работает

[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    d0_ = Cells(2, 4)
    If Not IsDate(d0_) Then Exit Sub
    d_ = Format(d0_, "m\/d\/yyyy")
    rd_ = Cells(Rows.Count, 4).End(3).Row
    If rd_ > 2 Then
        Cells(3, 4).Resize(rd_).ClearContents
    End If
    With ActiveSheet
        With .ListObjects("Ïåðå÷åíü_íàêë").Range
            .AutoFilter Field:=2, Operator:=xlFilterValues, Criteria2:=Array(1, d_)
            .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy Cells(3, 4)
            .AutoFilter Field:=2
        End With
        rd_ = Cells(Rows.Count, 4).End(3).Row
        If rd_ > 2 Then
            Application.AddCustomList ListArray:=Range("B3:B15")
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("F2:F" & rd_), CustomOrder:=Application.CustomListCount
                .SetRange Range("F2:F" & rd_)
                .Apply
            End With
            Application.DeleteCustomList ListNum:=Application.CustomListCount
        End If
    End With
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]
К сообщению приложен файл: 0794228.xlsm(14.5 Kb)
 
Ответить
Сообщение_Boroda_, Не работает. Я пытался подправить как мог, но все равно не работает

[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    d0_ = Cells(2, 4)
    If Not IsDate(d0_) Then Exit Sub
    d_ = Format(d0_, "m\/d\/yyyy")
    rd_ = Cells(Rows.Count, 4).End(3).Row
    If rd_ > 2 Then
        Cells(3, 4).Resize(rd_).ClearContents
    End If
    With ActiveSheet
        With .ListObjects("Ïåðå÷åíü_íàêë").Range
            .AutoFilter Field:=2, Operator:=xlFilterValues, Criteria2:=Array(1, d_)
            .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy Cells(3, 4)
            .AutoFilter Field:=2
        End With
        rd_ = Cells(Rows.Count, 4).End(3).Row
        If rd_ > 2 Then
            Application.AddCustomList ListArray:=Range("B3:B15")
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("F2:F" & rd_), CustomOrder:=Application.CustomListCount
                .SetRange Range("F2:F" & rd_)
                .Apply
            End With
            Application.DeleteCustomList ListNum:=Application.CustomListCount
        End If
    End With
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]

Автор - AVI
Дата добавления - 17.10.2018 в 12:48
_Boroda_ Дата: Среда, 17.10.2018, 13:07 | Сообщение № 4
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13514
Репутация: 5529 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Да, забыл строку с Header. Ну тогда и диапазон перепишу с 3-й строки
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    d0_ = Cells(2, 4)
    If Not IsDate(d0_) Then Exit Sub
    d_ = Format(d0_, "m\/d\/yyyy")
    rd_ = Cells(Rows.Count, 4).End(3).Row
    If rd_ > 2 Then
        Cells(3, 4).Resize(rd_).ClearContents
    End If
    With ActiveSheet
        With .ListObjects("Перечень_накл").Range
            .AutoFilter Field:=2, Operator:=xlFilterValues, Criteria2:=Array(1, d_)
            .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy Cells(3, 4)
            .AutoFilter Field:=2
        End With
        rd_ = Cells(Rows.Count, 4).End(3).Row
        If rd_ > 2 Then
            Application.AddCustomList ListArray:=Range("B3:B15")
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("D3:D" & rd_), CustomOrder:=Application.CustomListCount
                .SetRange Range("D3:D" & rd_)
                .Header = xlGuess
                .Apply
            End With
            Application.DeleteCustomList ListNum:=Application.CustomListCount
        End If
    End With
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеДа, забыл строку с Header. Ну тогда и диапазон перепишу с 3-й строки
[vba]
Код
Sub tt()
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    d0_ = Cells(2, 4)
    If Not IsDate(d0_) Then Exit Sub
    d_ = Format(d0_, "m\/d\/yyyy")
    rd_ = Cells(Rows.Count, 4).End(3).Row
    If rd_ > 2 Then
        Cells(3, 4).Resize(rd_).ClearContents
    End If
    With ActiveSheet
        With .ListObjects("Перечень_накл").Range
            .AutoFilter Field:=2, Operator:=xlFilterValues, Criteria2:=Array(1, d_)
            .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy Cells(3, 4)
            .AutoFilter Field:=2
        End With
        rd_ = Cells(Rows.Count, 4).End(3).Row
        If rd_ > 2 Then
            Application.AddCustomList ListArray:=Range("B3:B15")
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("D3:D" & rd_), CustomOrder:=Application.CustomListCount
                .SetRange Range("D3:D" & rd_)
                .Header = xlGuess
                .Apply
            End With
            Application.DeleteCustomList ListNum:=Application.CustomListCount
        End If
    End With
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 17.10.2018 в 13:07
AVI Дата: Среда, 17.10.2018, 14:07 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 453
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
_Boroda_, что-то не то...
Если дату поменять на октябрь то спирт "утекает" низ.
И если после работы макроса нажать на дискетку, то файл просто вылетает.
((
К сообщению приложен файл: 0754424.xlsm(14.5 Kb)
 
Ответить
Сообщение_Boroda_, что-то не то...
Если дату поменять на октябрь то спирт "утекает" низ.
И если после работы макроса нажать на дискетку, то файл просто вылетает.
((

Автор - AVI
Дата добавления - 17.10.2018 в 14:07
_Boroda_ Дата: Среда, 17.10.2018, 15:25 | Сообщение № 6
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13514
Репутация: 5529 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Ага, и у меня вылетает. Думал, что это так моя машинка своё "фи" выражает, ан нет.
Ну ладно, все равно создание пользовательских списков сортировки дело неблагодарное
По-другому переделал
К сообщению приложен файл: 0754424_2.xlsm(19.2 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеАга, и у меня вылетает. Думал, что это так моя машинка своё "фи" выражает, ан нет.
Ну ладно, все равно создание пользовательских списков сортировки дело неблагодарное
По-другому переделал

Автор - _Boroda_
Дата добавления - 17.10.2018 в 15:25
AVI Дата: Среда, 17.10.2018, 16:37 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 453
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
_Boroda_, В октябре спирт опять уехал вниз
 
Ответить
Сообщение_Boroda_, В октябре спирт опять уехал вниз

Автор - AVI
Дата добавления - 17.10.2018 в 16:37
_Boroda_ Дата: Среда, 17.10.2018, 16:41 | Сообщение № 8
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13514
Репутация: 5529 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Правильно. Его же нет в списке столбца В. Сначала сортируем то, что есть в списке для сортировки (по этому списку), затем по алфавиту то, чего в списке сортировки нет.


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПравильно. Его же нет в списке столбца В. Сначала сортируем то, что есть в списке для сортировки (по этому списку), затем по алфавиту то, чего в списке сортировки нет.

Автор - _Boroda_
Дата добавления - 17.10.2018 в 16:41
AVI Дата: Среда, 17.10.2018, 17:15 | Сообщение № 9
Группа: Проверенные
Ранг: Обитатель
Сообщений: 453
Репутация: 7 ±
Замечаний: 0% ±

Excel 2016
_Boroda_, Блин, я - дурак)) B3... а надо B2... Спасибо! Понял все!
 
Ответить
Сообщение_Boroda_, Блин, я - дурак)) B3... а надо B2... Спасибо! Понял все!

Автор - AVI
Дата добавления - 17.10.2018 в 17:15
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Отображение результат отбора с заданным порядком (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!