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

Вход

Регистрация

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

 

= Мир MS Excel/Сортировка и вывод на отдельный лист по критерию. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сортировка и вывод на отдельный лист по критерию. (Макросы/Sub)
Сортировка и вывод на отдельный лист по критерию.
vermut Дата: Четверг, 25.08.2016, 08:50 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 88
Репутация: 0 ±
Замечаний: 60% ±

Excel 2013
Есть изначальные данные четыре столбца А - Дата; В-Контрагент; С-Товар; D-Кол-во. Больше 10 тыс строк. Необходимо отсортировать и вывести на отдельный лист по критерию - список контрагентов.Наверное я сложно объяснила. Пример приложила, очень надеюсь на Вашу помощь.
К сообщению приложен файл: ___.xlsx(15Kb)
 
Ответить
СообщениеЕсть изначальные данные четыре столбца А - Дата; В-Контрагент; С-Товар; D-Кол-во. Больше 10 тыс строк. Необходимо отсортировать и вывести на отдельный лист по критерию - список контрагентов.Наверное я сложно объяснила. Пример приложила, очень надеюсь на Вашу помощь.

Автор - vermut
Дата добавления - 25.08.2016 в 08:50
vermut Дата: Четверг, 25.08.2016, 09:49 | Сообщение № 2
Группа: Пользователи
Ранг: Участник
Сообщений: 88
Репутация: 0 ±
Замечаний: 60% ±

Excel 2013
Ребята, как сделать?
 
Ответить
СообщениеРебята, как сделать?

Автор - vermut
Дата добавления - 25.08.2016 в 09:49
miver Дата: Четверг, 25.08.2016, 10:20 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 183
Репутация: 37 ±
Замечаний: 0% ±

Excel 2010
vermut, Вам обязательно макросом или просто не знаете, как это делается ручками?
 
Ответить
Сообщениеvermut, Вам обязательно макросом или просто не знаете, как это делается ручками?

Автор - miver
Дата добавления - 25.08.2016 в 10:20
vermut Дата: Четверг, 25.08.2016, 11:04 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 88
Репутация: 0 ±
Замечаний: 60% ±

Excel 2013
делается ручками?
А как это делается? когда список контрагентов имеет около 1 тыс наименований, а в критерии по контрагенту - их около 400?
 
Ответить
Сообщение
делается ручками?
А как это делается? когда список контрагентов имеет около 1 тыс наименований, а в критерии по контрагенту - их около 400?

Автор - vermut
Дата добавления - 25.08.2016 в 11:04
Manyasha Дата: Четверг, 25.08.2016, 11:04 | Сообщение № 5
Группа: Модераторы
Ранг: Старожил
Сообщений: 1586
Репутация: 662 ±
Замечаний: 0% ±

Excel 2007, 2010
vermut, можно так:
[vba]
Код
Sub FilterAndSort()
    With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With
    Dim contr, arrIndex(), lt&, dic As Object
    Dim data As Worksheet, res As Worksheet
    Set data = ThisWorkbook.Sheets(1)
    Set res = ThisWorkbook.Sheets("результат")
    
    Set dic = CreateObject("scripting.dictionary")
    With data
        For i = 2 To .Cells(Rows.Count, "f").End(xlUp).Row
            If Not dic.exists(Trim(.Cells(i, "f"))) Then dic.Add Trim(.Cells(i, "f")), i - 1
        Next i
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        contr = .Range("b2:b" & lr).Value
        ReDim arrIndex(UBound(contr) - 1, 0)
        For i = 1 To UBound(contr)
            If dic.exists(Trim(contr(i, 1))) Then
                arrIndex(i - 1, 0) = dic.Item(Trim(contr(i, 1)))
            Else
                arrIndex(i - 1, 0) = ""
            End If
        Next i
    End With
    
    With res
        .Range("a1:e" & .Cells(Rows.Count, 1).End(xlUp).Row).Clear
        data.Range("a1:d" & lr).Copy .[a1]
        .[e2].Resize(lr - 1) = arrIndex
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("e2:e" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange res.Range("a2:e" & lr)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Range(.Cells(WorksheetFunction.CountA(.Range("e2:e" & lr)) + 2, 1), .Cells(lr, "d")).Clear
        .Range("e2:e" & lr).Clear
    End With
    With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With
End Sub
[/vba]
К сообщению приложен файл: primer-1.xlsm(29Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеvermut, можно так:
[vba]
Код
Sub FilterAndSort()
    With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With
    Dim contr, arrIndex(), lt&, dic As Object
    Dim data As Worksheet, res As Worksheet
    Set data = ThisWorkbook.Sheets(1)
    Set res = ThisWorkbook.Sheets("результат")
    
    Set dic = CreateObject("scripting.dictionary")
    With data
        For i = 2 To .Cells(Rows.Count, "f").End(xlUp).Row
            If Not dic.exists(Trim(.Cells(i, "f"))) Then dic.Add Trim(.Cells(i, "f")), i - 1
        Next i
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        contr = .Range("b2:b" & lr).Value
        ReDim arrIndex(UBound(contr) - 1, 0)
        For i = 1 To UBound(contr)
            If dic.exists(Trim(contr(i, 1))) Then
                arrIndex(i - 1, 0) = dic.Item(Trim(contr(i, 1)))
            Else
                arrIndex(i - 1, 0) = ""
            End If
        Next i
    End With
    
    With res
        .Range("a1:e" & .Cells(Rows.Count, 1).End(xlUp).Row).Clear
        data.Range("a1:d" & lr).Copy .[a1]
        .[e2].Resize(lr - 1) = arrIndex
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("e2:e" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange res.Range("a2:e" & lr)
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        Range(.Cells(WorksheetFunction.CountA(.Range("e2:e" & lr)) + 2, 1), .Cells(lr, "d")).Clear
        .Range("e2:e" & lr).Clear
    End With
    With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With
End Sub
[/vba]

Автор - Manyasha
Дата добавления - 25.08.2016 в 11:04
vermut Дата: Четверг, 25.08.2016, 11:08 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 88
Репутация: 0 ±
Замечаний: 60% ±

Excel 2013
можно так
Все работает, огромное спасибо Вам.


Сообщение отредактировал vermut - Четверг, 25.08.2016, 11:41
 
Ответить
Сообщение
можно так
Все работает, огромное спасибо Вам.

Автор - vermut
Дата добавления - 25.08.2016 в 11:08
Gustav Дата: Пятница, 26.08.2016, 13:44 | Сообщение № 7
Группа: Друзья
Ранг: Старожил
Сообщений: 1211
Репутация: 484 ±
Замечаний: 0% ±

начинал с Excel 4.0...
Цитата miver, 25.08.2016 в 10:20, в сообщении № 3
делается ручками?
А как это делается? когда список контрагентов имеет около 1 тыс наименований, а в критерии по контрагенту - их около 400?

Можно ручками, можно. Идём по меню: Данные => Сортировка и фильтр => Дополнительно. Появляется форма "Расширенный фильтр". В ней:
[vba]
Код
Обработка: (*) скопировать результат в другое место

Исходный диапазон: $A$1:$D$15
Диапазон условий: $F$1:$F$6
Поместить результат в диапазон: $H$1:$K$1

Только уникальные записи: пусто

ОК
[/vba]
Или то же самое - записанным макросом (раз уж в разделе VBA):
[vba]
Код
Sub Макрос1()
    Range("A1:D15").AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=Range("F1:F6"), _
        CopyToRange:=Range("H1:K1"), _
        Unique:=False
End Sub
[/vba]

P.S. Можно также повыпендриваться при помощи запроса SQL (книга должна быть сохранена на диске, чтобы правильно отработало ThisWorkbook.FullName)
[vba]
Код
Sub selectData()
    
    Dim rst As Object
            
    Set rst = CreateObject("ADODB.Recordset")
            
    rst.Open _
    "SELECT * FROM [Лист1$A1:D65000] WHERE [Контрагент] IN (" & _
    "SELECT [Контрагент] FROM [Лист1$F1:F65000] WHERE Not IsNull([Контрагент])" & _
    ") ORDER BY 1, 2, 3, 4" _
    , _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & ThisWorkbook.FullName & ";" & _
    "Extended Properties='Excel 12.0;HDR=Yes'"
           
    [Лист1!H2].Resize(65000, 4).ClearContents
    [Лист1!H2].CopyFromRecordset rst

End Sub
[/vba]


Мой tip box - яд 41001663842605

Сообщение отредактировал Gustav - Пятница, 26.08.2016, 15:29
 
Ответить
Сообщение
Цитата miver, 25.08.2016 в 10:20, в сообщении № 3
делается ручками?
А как это делается? когда список контрагентов имеет около 1 тыс наименований, а в критерии по контрагенту - их около 400?

Можно ручками, можно. Идём по меню: Данные => Сортировка и фильтр => Дополнительно. Появляется форма "Расширенный фильтр". В ней:
[vba]
Код
Обработка: (*) скопировать результат в другое место

Исходный диапазон: $A$1:$D$15
Диапазон условий: $F$1:$F$6
Поместить результат в диапазон: $H$1:$K$1

Только уникальные записи: пусто

ОК
[/vba]
Или то же самое - записанным макросом (раз уж в разделе VBA):
[vba]
Код
Sub Макрос1()
    Range("A1:D15").AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=Range("F1:F6"), _
        CopyToRange:=Range("H1:K1"), _
        Unique:=False
End Sub
[/vba]

P.S. Можно также повыпендриваться при помощи запроса SQL (книга должна быть сохранена на диске, чтобы правильно отработало ThisWorkbook.FullName)
[vba]
Код
Sub selectData()
    
    Dim rst As Object
            
    Set rst = CreateObject("ADODB.Recordset")
            
    rst.Open _
    "SELECT * FROM [Лист1$A1:D65000] WHERE [Контрагент] IN (" & _
    "SELECT [Контрагент] FROM [Лист1$F1:F65000] WHERE Not IsNull([Контрагент])" & _
    ") ORDER BY 1, 2, 3, 4" _
    , _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & ThisWorkbook.FullName & ";" & _
    "Extended Properties='Excel 12.0;HDR=Yes'"
           
    [Лист1!H2].Resize(65000, 4).ClearContents
    [Лист1!H2].CopyFromRecordset rst

End Sub
[/vba]

Автор - Gustav
Дата добавления - 26.08.2016 в 13:44
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сортировка и вывод на отдельный лист по критерию. (Макросы/Sub)
Страница 1 из 11
Поиск:

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