Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Выбор всех значений из списка по условию при помощи макроса, а не формулы, многоразовый ВПР
 
#1
01.05.2021 20:27:26
Добрый день.
В отчетном файле есть необходимость забирать из списка размером более 10 000 строк данные о станциях по условию выбора из выпадающего списка предприятия.
На данный момент это происходит при помощи формулы массива. Как вы понимаете, с быстродействием все очень грустно, при том, что сам файл заточен на кучу задач.
Есть ли возможность вытащить необходимую информацию на другой лист макросом? И как вариант, вытащить не все станции, а только станции с не пустыми значениями больше ноля?
 
 
 
#2
01.05.2021 20:48:50
grand68,
Код
Sub MRSHKEI()
Dim ARR, ARR2, i As Long, lr As Long
Dim sh As Worksheet, sh2 As Worksheet
Set sh = Worksheets("Данные"): Set sh2 = Worksheets("Тест")
lr = sh.Cells(Rows.Count, 2).End(xlUp).Row
ARR = sh.Range("A6:F" & lr)
ReDim ARR2(1 To Application.WorksheetFunction.CountIfs(sh.Columns(6), ">0", sh.Columns(3), sh2.Cells(4, 2)), 1 To 2): K = 1
For i = LBound(ARR) To UBound(ARR)
    If ARR(i, 6) > 0 And sh2.Cells(4, 2) = ARR(i, 3) Then ARR2(K, 1) = ARR(i, 2): ARR2(K, 2) = ARR(i, 6): K = K + 1
Next i
sh2.Range("B7:C10000").ClearContents
sh2.Range("B7").Resize(UBound(ARR2), 2) = ARR2
End Sub
или перерасчет при измени предприятия в B4
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("B4")) Is Nothing Then
Dim ARR, ARR2, i As Long, lr As Long
Dim sh As Worksheet
Set sh = Worksheets("Äàííûå")
lr = sh.Cells(Rows.Count, 2).End(xlUp).Row
ARR = sh.Range("A6:F" & lr)
ReDim ARR2(1 To Application.WorksheetFunction.CountIfs(sh.Columns(6), ">0", sh.Columns(3), Target), 1 To 2): K = 1
For i = LBound(ARR) To UBound(ARR)
    If ARR(i, 6) > 0 And Target = ARR(i, 3) Then ARR2(K, 1) = ARR(i, 2): ARR2(K, 2) = ARR(i, 6): K = K + 1
Next i
Range("B7:C10000").ClearContents
Range("B7").Resize(UBound(ARR2), 2) = ARR2
End If
End Sub
Изменено: Mershik - 01.05.2021 20:49:12
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#3
01.05.2021 21:03:26
Mershik, спасибо. Как сделать макрос без условия не нулевых объемов я сообразил. ))
Большое спасибо.
 
 
 
#4
01.05.2021 21:04:57
Цитата
grand68 написал:
. Как сделать макрос без условия не нулевых объемов я сообразил. ))
не понял...?
предложенные мною 2 макроса это и делают  
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#5
02.05.2021 11:54:32
Я имел в виду, вариант, когда, вообще все пять станций вытаскиваются, а не только станции с ненулевыми объемами.

Вставляю код в файл. Заменяю на свои листы, строки, столбцы. Код начинает ругаться на K. Пишет, что переменная не определена.
Могу я определить ее как Variant и все?
Код
Sub Станции()
Dim ARR, ARR2, i As Long, lr As Long
Dim sh As Worksheet, sh2 As Worksheet
Set sh = Worksheets("СтанцииТарифы"): Set sh2 = Worksheets("РасчетыЛюбойЗавод)
lr = sh.Cells(Rows.Count, 3).End(xlUp).Row
ARR = sh.Range("A2:Y" & lr)
ReDim ARR2(1 To Application.WorksheetFunction.CountIfs(sh.Columns(25), ">0", sh.Columns(4), sh2.Cells(3, 2)), 1 To 2): K = 1
For i = LBound(ARR) To UBound(ARR)
    If ARR(i, 25) > 0 And sh2.Cells(3, 2) = ARR(i, 4) Then ARR2(K, 1) = ARR(i, 2): ARR2(K, 2) = ARR(i, 4): K = K + 1
Next i
sh2.Range("B14:E161").ClearContents
sh2.Range("B14").Resize(UBound(ARR2), 4) = ARR2
End Sub
 
 
 
#6
02.05.2021 12:01:18
Код
Dim K As Long
 
 
 
#7
02.05.2021 12:04:06
Правильно - объявлять все переменные. И объявлять с тем типом , какие данные предполагается в них передавать.
Код
Dim k as Long
 
 
 
#8
02.05.2021 12:12:43
А, подскажите, если не сложно, еще один момент.

Когда выбираю предприятие у которого нет объемов, макрос начинает ругаться на эту строчку:
Код
ReDim ARR2(1 To Application.WorksheetFunction.CountIfs(sh.Columns(25), ">0", sh.Columns(4), sh2.Cells(3, 2)), 1 To 2)
Пишет, что Subscript out of range.
Чего ему не хватает?
 
 
 
#9
02.05.2021 12:18:49
grand68, он не находит и говорит о том что нельзя создать массив нулевого размера...
добавте перед это строкой  вот такую строку
Код
On Error Resume Next
Изменено: Mershik - 02.05.2021 12:20:39
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#10
02.05.2021 12:31:50
Цитата
Mershik написал: добавте... On Error Resume Next
Советую поменьше использовать обработчик ошибок.
В данном примере - не нужно скупиться на строки. Сначала определить значение, после этого проверить, можно ли определять размерность массива.
Да и такой код (в сообщении №8) плохо читается.
 
 
 
#11
02.05.2021 12:37:45
Цитата
vikttur написал:
Советую поменьше использовать обработчик ошибок.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("B4")) Is Nothing Then
Dim ARR, ARR2, i As Long, lr As Long
Dim sh As Worksheet
Set sh = Worksheets("Данные")
lr = sh.Cells(Rows.Count, 2).End(xlUp).Row
ARR = sh.Range("A6:F" & lr)
s = Application.WorksheetFunction.CountIfs(sh.Columns(6), ">0", sh.Columns(3), Target)
If s > 0 Then
ReDim ARR2(1 To s, 1 To 2): K = 1
For i = LBound(ARR) To UBound(ARR)
    If ARR(i, 6) > 0 And Target = ARR(i, 3) Then ARR2(K, 1) = ARR(i, 2): ARR2(K, 2) = ARR(i, 6): K = K + 1
Next i
    Range("B7:C10000").ClearContents
    Range("B7").Resize(UBound(ARR2), 2) = ARR2
Else
    Range("B7:C10000").ClearContents
End If
End If
End Sub
Изменено: Mershik - 02.05.2021 12:37:56
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#12
02.05.2021 14:04:34
У этой моей задачи есть, еще одна составляющая.

Второй итерацией необходимо вернуть объемы на лист с данными, но, уже перераспределив по другим предприятиям (а, может, и оставить на первоначальном предприятии).

Формула (я ее вставил), конечно, делает это, но где формула и 10 000 строк и более, там и торможение всего процесса пересчета.

Можно ли, по нажатию кнопки, макросом вернуть данные в конкретные ячейки по условию названия станции и выбранного для этого объема и станции предприятия, не забивая данные во всем диапазоне?

PS. Уважаемые модераторы, есть ли необходимость под это создавать отдельную тему?
 
 
 
#13
02.05.2021 14:11:12
Цитата
2.6. Один вопрос - одна тема. Не следует в открываемой теме обозначать и задавать сразу несколько вопросов.
 
 
 
Страницы: 1
Наверх