Заполнение диапазона макросом

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Заполнение диапазона макросом (Макросы/Sub)

tyler14

Дата: Четверг, 29.06.2017, 18:00 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 3

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Добрый день!

Подскажите, как можно оптимизировать цикл по заполнению ячеек, поскольку сейчас выполнение макроса занимает от 3 до 5 мин. Как можно его ускорить, либо быть может заменить имеющийся цикл For next на другую более быструю структуру.

Смысл работы нижеприведенного макроса следующий - заполнение нескольких диапозонов на Листе значениями, рассчитанными суммеслимн, которые берём из данных с другого листа. Проблема в скорости выполнения макроса.

Ниже приведена часть макроса, которую надо оптимизировать.
[vba]

Код

Option Explicit
Sub Rachet()

Dim k As Integer, i As Integer, j As Integer
Dim a, b, c, d, e As Range
Dim Sum(1 To 18) As Long
Dim sheet1, sheet2 As Worksheet

Set sheet1 = Worksheets("Cash flow")
Set sheet2 = Worksheets("Реестр операций")
Set a = sheet2.Range("H3:H999000")
Set b = sheet2.Range("F3:F999000")
Set c = sheet2.Range("C3:C999000")
Set d = sheet2.Range("L3:L999000")
Set e = sheet2.Range("G3:G999000")

For j = 1 To 70
k = 3
For i = 4 To 35
Sum(1) = Application.WorksheetFunction.SumIfs(a, b, sheet1.Cells(j + 7, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 7, 2) & "*")
Cells(j + 7, i) = Sum(1)

Sum(2) = Application.WorksheetFunction.SumIfs(a, b, sheet1.Cells(j + 79, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 79, 2) & "*")
Cells(j + 79, i) = Sum(2)

Sum(3) = Application.WorksheetFunction.SumIfs(e, b, sheet1.Cells(j + 150, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 150, 2) & "*")
Cells(j + 150, i) = Sum(3)

Sum(4) = Application.WorksheetFunction.SumIfs(a, b, sheet1.Cells(j + 223, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 223, 2) & "*")
Cells(j + 223, i) = Sum(4)

Sum(5) = Application.WorksheetFunction.SumIfs(e, b, sheet1.Cells(j + 294, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 294, 2) & "*")
Cells(j + 294, i) = Sum(5)

Sum(6) = Application.WorksheetFunction.SumIfs(e, b, sheet1.Cells(j + 367, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 367, 2) & "*")
Cells(j + 367, i) = Sum(6)

Sum(7) = Application.WorksheetFunction.SumIfs(a, b, sheet1.Cells(j + 442, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 442, 2) & "*")
Cells(j + 442, i) = Sum(7)

Sum(8) = Application.WorksheetFunction.SumIfs(e, b, sheet1.Cells(j + 513, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 513, 2) & "*")
Cells(j + 513, i) = Sum(8)

Sum(9) = Application.WorksheetFunction.SumIfs(a, b, sheet1.Cells(j + 589, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 589, 2) & "*")
Cells(j + 589, i) = Sum(9)

Sum(10) = Application.WorksheetFunction.SumIfs(e, b, sheet1.Cells(j + 660, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 660, 2) & "*")
Cells(j + 660, i) = Sum(10)

Sum(11) = Application.WorksheetFunction.SumIfs(a, b, sheet1.Cells(j + 736, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 736, 2) & "*")
Cells(j + 736, i) = Sum(11)

Sum(12) = Application.WorksheetFunction.SumIfs(e, b, sheet1.Cells(j + 807, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 807, 2) & "*")
Cells(j + 807, i) = Sum(12)

Sum(13) = Application.WorksheetFunction.SumIfs(a, b, sheet1.Cells(j + 883, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 883, 2) & "*")
Cells(j + 883, i) = Sum(13)

Sum(14) = Application.WorksheetFunction.SumIfs(e, b, sheet1.Cells(j + 954, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 954, 2) & "*")
Cells(j + 954, i) = Sum(14)

Sum(15) = Application.WorksheetFunction.SumIfs(a, b, sheet1.Cells(j + 1027, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 1027, 2) & "*")
Cells(j + 1027, i) = Sum(15)

Sum(16) = Application.WorksheetFunction.SumIfs(e, b, sheet1.Cells(j + 1098, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 1098, 2) & "*")
Cells(j + 1098, i) = Sum(16)

Sum(17) = Application.WorksheetFunction.SumIfs(a, b, sheet1.Cells(j + 1176, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 1176, 2) & "*")
Cells(j + 1176, i) = Sum(17)

Sum(18) = Application.WorksheetFunction.SumIfs(e, b, sheet1.Cells(j + 1247, 3), c, sheet1.Cells(2, k + 1), d, "*" & sheet1.Cells(j + 1247, 2) & "*")
Cells(j + 1247, i) = Sum(18)

k = k + 1
Next i
Next j

End Sub

[/vba]

Код

[/vba]tyler14

К сообщению приложен файл: 9488519.7z (82.9 Kb)

Сообщение отредактировал tyler14 - Пятница, 30.06.2017, 10:01

Ответить

СообщениеДобрый день!

Подскажите, как можно оптимизировать цикл по заполнению ячеек, поскольку сейчас выполнение макроса занимает от 3 до 5 мин. Как можно его ускорить, либо быть может заменить имеющийся цикл For next на другую более быструю структуру.

Смысл работы нижеприведенного макроса следующий - заполнение нескольких диапозонов на Листе значениями, рассчитанными суммеслимн, которые берём из данных с другого листа. Проблема в скорости выполнения макроса.

Ниже приведена часть макроса, которую надо оптимизировать.
[vba]

Код

[/vba]

Автор - tyler14
Дата добавления - 29.06.2017 в 18:00

Manyasha

Дата: Четверг, 29.06.2017, 18:45 | Сообщение № 2

Группа: Модераторы

Ранг: Старожил

Сообщений: 2198

Репутация: 898 ±

Замечаний: 0% ±

Excel 2010, 2016

Оформите код тегами (кнопка #).
Приложите файл для примера. Все данные не нужны, оставьте строк 10-20. Главное - структура и форматы.

ЯД: 410013299366744 WM: R193491431804

Ответить

tyler14

Дата: Пятница, 30.06.2017, 10:11 | Сообщение № 3

Группа: Пользователи

Ранг: Прохожий

Сообщений: 3

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Приложил файл - он содержит 2 листа :
1) Реестр операция - он содержит исходные данные
2) Cash flow - на него выводятся значения из Реестра операций с помощью формулы Суммеслимн (диапазоны суммирования "Поступления", "Списания", диапазоны условий - "Статья затрат / ДДС", "Вид деят-ти", "Мес.", условия содержатся на листе Реестр операций в столбцах B и C.

Т. к. объем вложений ограничен, пришлось удалить из файла сам макрос.
Ниже полная версия кода.

Доступно только для пользователей

Сообщение отредактировал tyler14 - Пятница, 30.06.2017, 10:12

Ответить

AndreTM

Дата: Пятница, 30.06.2017, 11:52 | Сообщение № 4

Группа: Друзья

Ранг: Старожил

Сообщений: 1762

Репутация: 500 ±

Замечаний: 0% ±

2003 & 2010

У меня создается впечатление, что вы пытаетесь макросом считать то, что вам быстрее и проще посчитает сводная. Ну или Power Query. А уж вид вашей таблички на листе CashFlow мне подозрительно напоминает один из видов PowerPivot

Хотя, если у вас в источнике данных не миллион строк, а хотя бы 100к - то можно и макрос попробовать "оптимизировать". Хотя бы только за счет "урезания бобра" до реального размера строчек с данными и отказа от кучи суммеслимн(), да ещё и несколько раз считающих разные условия по одним и тем же диапазонам... хотя полсе этого, опять ,приходим к вопросу " а все же не задействовать ли DAX и PowerQuery" и т.д.

Skype: andre.tm.007
Donate: Qiwi: 9517375010

Ответить

tyler14

Дата: Пятница, 30.06.2017, 16:32 | Сообщение № 5

Группа: Пользователи

Ранг: Прохожий

Сообщений: 3

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Конечно руками с помощью тех же сводных или использования формул заполнить данную форму можно легко.
Но интересна именно автоматизация процесса расчета и заполнения данного отчета

К сожалению о Power Pivot слышал только краем уха и поэтому нет представления о его функционале...

Немного порывшись на форумах, нашел еще один способ заполнения (наподобие сводной).
Вот то, что у меня получилось адаптировать к моей таблице.

Но мне надо еще вставить одно условие по последнему столбцу "Вид операции".
[vba]

Код

Sub RaschetN2()
Dim x, y(), i&, k&, n&, rw&, cl&
Dim mn, yr, s$
mn = Array("январь", "февраль", "март", "апрель", "май", "июнь", "июль", "август", "сентябрь", "октябрь", "ноябрь", "декабрь")
yr = Array(2015, 2016, 2017)    'можно, например, так: yr = Array(2016, 2017, 2018, 2019)
x = Sheets("Реестр операций").Range("A2").CurrentRegion.Value
ReDim y(1 To UBound(x) + 2, 1 To (UBound(mn) + 1) * (UBound(yr) + 1) + 1)

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1: k = 1
    For n = 0 To UBound(yr)    'years
        For i = 0 To UBound(mn)    'months
            k = k + 1: .Item(mn(i) & yr(n)) = k    '"месяц&год" - номер столбца
            y(1, k) = yr(n): y(2, k) = mn(i)
        Next i
    Next n

    cl = 1: k = 2
    For i = 3 To UBound(x)
        If .Exists(x(i, 7)) Then
            rw = .Item(x(i, 7))
        Else
            k = k + 1: .Item(x(i, 7)) = k
            y(k, 1) = x(i, 7): rw = k
        End If

        s = x(i, 3) & x(i, 4)
        If .Exists(s) Then
            cl = .Item(s)
        End If
        y(rw, cl) = y(rw, cl) + x(i, 9)
    Next i
End With

With Sheets("Cash flow")
    .Range("C3").CurrentRegion.ClearContents
    .Range("C3").Resize(k, UBound(y, 2)).Value = y()
    .Activate
End With
End Sub

[/vba]

Код

[/vba]tyler14

К сообщению приложен файл: 5691485.7z (56.1 Kb)

Сообщение отредактировал tyler14 - Пятница, 30.06.2017, 17:05

Ответить

СообщениеКонечно руками с помощью тех же сводных или использования формул заполнить данную форму можно легко.
Но интересна именно автоматизация процесса расчета и заполнения данного отчета

Код

[/vba]

Автор - tyler14
Дата добавления - 30.06.2017 в 16:32

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Заполнение диапазона макросом (Макросы/Sub)

Страница 1 из 1
1