К продолжению прошлой темы, прошу подсказать что делаю не так при делении данных по листам, привожу готовый макрос, благодарю Hugo, при малом количестве по полю Код работает вроде правильно, но если увеличиваю количество строк до 200 тыс. и условий деления по листам до 10 ( в коде прописано условие "сумма" или "количество", я добавляю еще варианты условий) он перестает отрабатывать, оставляет листы не заполненными.
Добрый день,
К продолжению прошлой темы, прошу подсказать что делаю не так при делении данных по листам, привожу готовый макрос, благодарю Hugo, при малом количестве по полю Код работает вроде правильно, но если увеличиваю количество строк до 200 тыс. и условий деления по листам до 10 ( в коде прописано условие "сумма" или "количество", я добавляю еще варианты условий) он перестает отрабатывать, оставляет листы не заполненными.ssm
Добрый день. Явно что-то делаете не так. Ибо если в существующем коде переставить строки вот так:
a = Sheets("сумма").Range("A5").CurrentRegion.Rows(1).Resize(2).Value ReDim b(1To col.Count, 1To6) For i = 1To col.Count
b(i, 1) = col(i) For ii = 2ToUBound(a, 2)
t = b(i, 1) & "|" & a(2, ii) & "|" & a(1, ii)
b(i, ii) = .Item(t) Next Next
Sheets("сумма").Range("A6").Resize(UBound(b), UBound(b, 2)) = b
a = Sheets("количество").Range("A5").CurrentRegion.Rows(1).Resize(2).Value ReDim b1(1To col.Count, 1To6) For i = 1To col.Count
b1(i, 1) = col(i) For ii = 2ToUBound(a, 2)
t = b1(i, 1) & "|" & a(2, ii) & "|" & a(1, ii)
b1(i, ii) = .Item(t) Next Next
Sheets("количество").Range("A6").Resize(UBound(b1), UBound(b1, 2)) = b1
видно что можно обойтись одним таким блоком, и одним массивом b, нужно только вывести это в подпроцедуру и менять название листа, и если сработает для одного листа, то сработает и для всех таких же других.
Добрый день. Явно что-то делаете не так. Ибо если в существующем коде переставить строки вот так:
a = Sheets("сумма").Range("A5").CurrentRegion.Rows(1).Resize(2).Value ReDim b(1To col.Count, 1To6) For i = 1To col.Count
b(i, 1) = col(i) For ii = 2ToUBound(a, 2)
t = b(i, 1) & "|" & a(2, ii) & "|" & a(1, ii)
b(i, ii) = .Item(t) Next Next
Sheets("сумма").Range("A6").Resize(UBound(b), UBound(b, 2)) = b
a = Sheets("количество").Range("A5").CurrentRegion.Rows(1).Resize(2).Value ReDim b1(1To col.Count, 1To6) For i = 1To col.Count
b1(i, 1) = col(i) For ii = 2ToUBound(a, 2)
t = b1(i, 1) & "|" & a(2, ii) & "|" & a(1, ii)
b1(i, ii) = .Item(t) Next Next
Sheets("количество").Range("A6").Resize(UBound(b1), UBound(b1, 2)) = b1
видно что можно обойтись одним таким блоком, и одним массивом b, нужно только вывести это в подпроцедуру и менять название листа, и если сработает для одного листа, то сработает и для всех таких же других.Hugo
Sub кол() Dim a(), i&, x&, t$, col AsNew Collection Dim dic AsObject, arr
Set dic = CreateObject("scripting.dictionary")
arr = Split("количество сумма") With dic
.comparemode = 1
a = Sheets("данные").Range("A1").CurrentRegion.Value
OnErrorResumeNext For i = 2ToUBound(a)
col.Add a(i, 1), Trim(a(i, 1)) For x = 0ToUBound(arr)
t = a(i, 1) & "|" & a(i, 4) & "|" & arr(x)
.Item(t) = .Item(t) + a(i, x + 2) Next Next OnErrorGoTo0
For x = 0ToUBound(arr)
подпроцедура arr(x), col, dic Next
EndWith EndSub
PrivateSub подпроцедура(лист, col, dic AsObject) Dim a, b, i&, ii&, t$
With Sheets(лист).Range("A5").CurrentRegion
.Rows(3).Resize(.Rows.Count - 2).ClearContents EndWith
a = Sheets(лист).Range("A5").CurrentRegion.Rows(1).Resize(2).Value ReDim b(1To col.Count, 1To6) For i = 1To col.Count
b(i, 1) = col(i) For ii = 2ToUBound(a, 2)
t = b(i, 1) & "|" & a(2, ii) & "|" & a(1, ii) If dic.exists(t) Then b(i, ii) = dic.Item(t) Next Next
Sheets(лист).Range("A6").Resize(UBound(b), UBound(b, 2)) = b
EndSub
Только вот на практике диапазон "A6:M13" думаю нужно корректировать динамически. Можно привязываться к тому же Sheets(лист).Range("A5").CurrentRegion - изменил код.
Итоговый вариант, подправил массив arr
Option Explicit
Sub кол() Dim a(), i&, x&, t$, col AsNew Collection Dim dic AsObject, arr
Set dic = CreateObject("scripting.dictionary")
arr = Split("количество сумма") With dic
.comparemode = 1
a = Sheets("данные").Range("A1").CurrentRegion.Value
OnErrorResumeNext For i = 2ToUBound(a)
col.Add a(i, 1), Trim(a(i, 1)) For x = 0ToUBound(arr)
t = a(i, 1) & "|" & a(i, 4) & "|" & arr(x)
.Item(t) = .Item(t) + a(i, x + 2) Next Next OnErrorGoTo0
For x = 0ToUBound(arr)
подпроцедура arr(x), col, dic Next
EndWith EndSub
PrivateSub подпроцедура(лист, col, dic AsObject) Dim a, b, i&, ii&, t$
With Sheets(лист).Range("A5").CurrentRegion
.Rows(3).Resize(.Rows.Count - 2).ClearContents EndWith
a = Sheets(лист).Range("A5").CurrentRegion.Rows(1).Resize(2).Value ReDim b(1To col.Count, 1To6) For i = 1To col.Count
b(i, 1) = col(i) For ii = 2ToUBound(a, 2)
t = b(i, 1) & "|" & a(2, ii) & "|" & a(1, ii) If dic.exists(t) Then b(i, ii) = dic.Item(t) Next Next
Sheets(лист).Range("A6").Resize(UBound(b), UBound(b, 2)) = b
EndSub
Только вот на практике диапазон "A6:M13" думаю нужно корректировать динамически. Можно привязываться к тому же Sheets(лист).Range("A5").CurrentRegion - изменил код.Hugo
Да, чуть ошибся, не потестил на пустом листе... А зачем оно нужно - ну ведь у Вас в коде есть очистка диапазона. Но не привязана к данным - вдруг их там будет больше?
Да, чуть ошибся, не потестил на пустом листе... А зачем оно нужно - ну ведь у Вас в коде есть очистка диапазона. Но не привязана к данным - вдруг их там будет больше?Hugo
Hugo, я о том что ваш кусок файла так же растягивается на заполненный диапазон данными и очищает его. Просто, я, программированием VBA занимаюсь по необходимости когда совсем прижмет из-за объем данных и формулы уже не справляются:) Только сейчас с вашей помощью начал понимать как работает Resize:) Большое спасибо что вы есть, и есть кто может поделиться опытом.
Hugo, я о том что ваш кусок файла так же растягивается на заполненный диапазон данными и очищает его. Просто, я, программированием VBA занимаюсь по необходимости когда совсем прижмет из-за объем данных и формулы уже не справляются:) Только сейчас с вашей помощью начал понимать как работает Resize:) Большое спасибо что вы есть, и есть кто может поделиться опытом.ssm
Сообщение отредактировал ssm - Понедельник, 15.06.2020, 20:16
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
