Есть изначальные данные четыре столбца А - Дата; В-Контрагент; С-Товар; D-Кол-во. Больше 10 тыс строк. Необходимо отсортировать и вывести на отдельный лист по критерию - список контрагентов.Наверное я сложно объяснила. Пример приложила, очень надеюсь на Вашу помощь.
Есть изначальные данные четыре столбца А - Дата; В-Контрагент; С-Товар; D-Кол-во. Больше 10 тыс строк. Необходимо отсортировать и вывести на отдельный лист по критерию - список контрагентов.Наверное я сложно объяснила. Пример приложила, очень надеюсь на Вашу помощь.vermut
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]
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
Цитата 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'"
Цитата 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'"