Добрый день, форумчане! Совсем зашел в глухой угол Задача следующая (необходимо выполнить в макросе): Есть большой перечень данных из которых необходимо выбрать нужные и "свернуть" их в "сводную таблицу" по следующим условиям: в выбранных данных есть 4 колонки. Если есть совпадения по первой+второй в разных строках, то суммировать третью и четвертую.
Необходимо получить: Параметр1 Параметр2 Сумма1 Сумма2 Вишня ранняя 50 70 Яблоня средняя 20 20 Яблоня ранняя 10 50
Пытался провернуть это дело на циклах и массивах, получается не особо, да и думаю что так не оптимально. Прошу помощи в подсказке как "наиболее правильно" выполнить оное поделится ссылкой на какой-либо способ аналогичного решения или же дельным советом. Буду премного благодарен
Моя попытка с массивами и циклами:
П.С. Ошибку выдает на данном этапе т.к. не правильна задан верхний предел в цикле [vba]
Код
Private Sub ZPredP()
Dim inputData As Variant Dim iRow As Long Dim i As Long Dim ii As Long Dim tmpR1, tmpR2, tmpR3, tmpR4 Dim outPut()
For i = 2 To UBound(inputData) For ii = 1 To UBound(outPut)) If inputData(i, 1) = outPut(1, ii) _ And inputData(i, 2) = outPut(2, ii) Then outPut(3, ii) = outPut(3, ii) + inputData(i, 3) outPut(4, ii) = outPut(4, ii) + inputData(i, 4) Else: ReDim Preserve outPut(4, ii + 1) outPut(1, ii + 1) = inputData(i, 1) outPut(2, ii + 1) = inputData(i, 2) outPut(3, ii + 1) = inputData(i, 3) outPut(4, ii + 1) = inputData(i, 4) End If Next Next
End Sub
[/vba]
Добрый день, форумчане! Совсем зашел в глухой угол Задача следующая (необходимо выполнить в макросе): Есть большой перечень данных из которых необходимо выбрать нужные и "свернуть" их в "сводную таблицу" по следующим условиям: в выбранных данных есть 4 колонки. Если есть совпадения по первой+второй в разных строках, то суммировать третью и четвертую.
Необходимо получить: Параметр1 Параметр2 Сумма1 Сумма2 Вишня ранняя 50 70 Яблоня средняя 20 20 Яблоня ранняя 10 50
Пытался провернуть это дело на циклах и массивах, получается не особо, да и думаю что так не оптимально. Прошу помощи в подсказке как "наиболее правильно" выполнить оное поделится ссылкой на какой-либо способ аналогичного решения или же дельным советом. Буду премного благодарен
Моя попытка с массивами и циклами:
П.С. Ошибку выдает на данном этапе т.к. не правильна задан верхний предел в цикле [vba]
Код
Private Sub ZPredP()
Dim inputData As Variant Dim iRow As Long Dim i As Long Dim ii As Long Dim tmpR1, tmpR2, tmpR3, tmpR4 Dim outPut()
For i = 2 To UBound(inputData) For ii = 1 To UBound(outPut)) If inputData(i, 1) = outPut(1, ii) _ And inputData(i, 2) = outPut(2, ii) Then outPut(3, ii) = outPut(3, ii) + inputData(i, 3) outPut(4, ii) = outPut(4, ii) + inputData(i, 4) Else: ReDim Preserve outPut(4, ii + 1) outPut(1, ii + 1) = inputData(i, 1) outPut(2, ii + 1) = inputData(i, 2) outPut(3, ii + 1) = inputData(i, 3) outPut(4, ii + 1) = inputData(i, 4) End If Next Next
Sub Мяу() Dim arr, a, ditem, i& arr = [a1].CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) If .exists(arr(i, 1) & arr(i, 2)) Then a = .Item(arr(i, 1) & arr(i, 2)) a(3) = a(3) + arr(i, 3) a(4) = a(4) + arr(i, 4) .Item(arr(i, 1) & arr(i, 2)) = a Else a = Application.Index(arr, i, 0) .Item(arr(i, 1) & arr(i, 2)) = a End If Next ditem = .Items ReDim arr(1 To .Count, 1 To 4) For i = 1 To UBound(arr) arr(i, 1) = ditem(i - 1)(1) arr(i, 2) = ditem(i - 1)(2) arr(i, 3) = ditem(i - 1)(3) arr(i, 4) = ditem(i - 1)(4) Next [f1].Resize(UBound(arr), 4) = arr End With End Sub
[/vba]
[vba]
Код
Sub Мяу() Dim arr, a, ditem, i& arr = [a1].CurrentRegion.Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr) If .exists(arr(i, 1) & arr(i, 2)) Then a = .Item(arr(i, 1) & arr(i, 2)) a(3) = a(3) + arr(i, 3) a(4) = a(4) + arr(i, 4) .Item(arr(i, 1) & arr(i, 2)) = a Else a = Application.Index(arr, i, 0) .Item(arr(i, 1) & arr(i, 2)) = a End If Next ditem = .Items ReDim arr(1 To .Count, 1 To 4) For i = 1 To UBound(arr) arr(i, 1) = ditem(i - 1)(1) arr(i, 2) = ditem(i - 1)(2) arr(i, 3) = ditem(i - 1)(3) arr(i, 4) = ditem(i - 1)(4) Next [f1].Resize(UBound(arr), 4) = arr End With End Sub
Добрый день, всем! Можно узнать, Rioran, а почему ваш макрос не работает если его скопировать в личную книгу макросов?? А работают только если вставлять как исходный текст!? Новые листы переименованы соответственно в "Data".
Добрый день, всем! Можно узнать, Rioran, а почему ваш макрос не работает если его скопировать в личную книгу макросов?? А работают только если вставлять как исходный текст!? Новые листы переименованы соответственно в "Data".baaur
Сообщение отредактировал baaur - Вторник, 03.06.2014, 11:14
А ларчик просто открывался. Мой макрос написан так, что работает с любым активным в данный момент листом, а макрос Rioran только с листом Data, причем только той книги, в которой живет. [vba]
Код
With ThisWorkbook.Sheets("Data")
[/vba]
А ларчик просто открывался. Мой макрос написан так, что работает с любым активным в данный момент листом, а макрос Rioran только с листом Data, причем только той книги, в которой живет. [vba]
baaur, почему выбрали именно этот код? Потому что он выглядит серьёзнее (больше), или потому что понятнее? (хотя раз не работал и не исправили - не понятнее...) Я бы взял тот что побыстрее...
baaur, почему выбрали именно этот код? Потому что он выглядит серьёзнее (больше), или потому что понятнее? (хотя раз не работал и не исправили - не понятнее...) Я бы взял тот что побыстрее... Hugo
Hugo, я его смог адаптировать под свои нужды, то есть он для меня был более понятен. То что не смог исправить, это для личной книги, а как исходный текст он работал.(у меня пока еще мало знаний). На счет времени, данные из 12 столбцов и 3400 строк 5-10 секунд - это мне кажется довольно быстро он работает.
Hugo, я его смог адаптировать под свои нужды, то есть он для меня был более понятен. То что не смог исправить, это для личной книги, а как исходный текст он работал.(у меня пока еще мало знаний). На счет времени, данные из 12 столбцов и 3400 строк 5-10 секунд - это мне кажется довольно быстро он работает. baaur
А Мяу работает за "Мяу". Длительность произнесения "Мяу" замерьте секундомером.
Ran, у меня не получается адаптировать ваш макрос под свои нужды, мне нужно было что бы Параметры 1,2,3,5 если равны то параметр 4 суммировался, то есть если есть совпадения по первой+второй+третей+пятой в разных строках, то суммировать четвертую.
А Мяу работает за "Мяу". Длительность произнесения "Мяу" замерьте секундомером.
Ran, у меня не получается адаптировать ваш макрос под свои нужды, мне нужно было что бы Параметры 1,2,3,5 если равны то параметр 4 суммировался, то есть если есть совпадения по первой+второй+третей+пятой в разных строках, то суммировать четвертую.baaur
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
