Промежуточные итоги vba excel - Word и Excel - помощь в работе с программами

132 / 15 / 2

Регистрация: 27.11.2013

Сообщений: 509

Подсчет промежуточных итогов в таблице переменного размера

04.11.2015, 22:27. Показов 8562. Ответов 10

Есть таблица, кол-во строк в которой меняется. Образец прилагается. В желтых строчках нужно ввести формулы промежут. итогов, например сумма и среднее. Я делаю по-школьному — рассчитываю границы промежуточных рейнджей (это тикеры в 4 столбце), а потом с пом. формул R1C1 циклом обсчитываю всю таблицу. Подозреваю, что это не самый эффективный метод — считает очень долго. Можно как-то оптимизировать процесс через массивы или объектные переменные? Причем в промежут. итогах мне нужны не значения, а именно формулы — они важны в текущей работе для быстрого подсчета.

pashulka

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

04.11.2015, 22:47

Сообщение было отмечено shavka как решение

Решение

Один из возможных вариантов :

Visual Basic

Private Sub Test()
    Application.ScreenUpdating = False
    Dim iSource As Range
    For Each iSource In [B:B].SpecialCells(xlConstants, xlNumbers).Areas
        iSource(0, 3).Formula = "=SUBTOTAL(1," & iSource.Offset(, 3).Address & ")"
        iSource(0, 4).Formula = "=SUBTOTAL(9," & iSource.Offset(, 3).Address & ")"
    Next
    Application.ScreenUpdating = True
End Sub

Казанский

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

04.11.2015, 22:56

shavka, есть предложение задействовать штатную команду «Промежуточные итоги». Но для этого придется удалять существующие желтые строки. Все это делает следующий макрос, полученный в основном записью ручных действий.

Visual Basic

Sub shavka()
  Cells.AutoFilter 3, "Тикер"
  Range("2:" & Rows.Count).SpecialCells(xlCellTypeVisible).Delete
  ActiveSheet.AutoFilterMode = False
  Cells.Sort Range("C1"), xlAscending, Header:=xlYes
  Range("A1").Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(4, 5), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=False
  Range("E:E").Replace "=SUBTOTAL(9", "=SUBTOTAL(1", xlPart
End Sub

pashulka

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

05.11.2015, 00:16

Если сумму необходимо считать по столбцу D , а среднее по столбцу E , то небольшое изменение :

Visual Basic

Private Sub Test()
    Application.ScreenUpdating = False
    Dim iSource As Range
    For Each iSource In [B:B].SpecialCells(xlConstants, xlNumbers).Areas
        iSource(0, 3) = "=SUBTOTAL(9," & iSource.Offset(, 2).Address & ")"
        iSource(0, 4) = "=SUBTOTAL(1," & iSource.Offset(, 3).Address & ")"
    Next
    Application.ScreenUpdating = True
End Sub

132 / 15 / 2

Регистрация: 27.11.2013

Сообщений: 509

05.11.2015, 02:12

[ТС]

чо то там у вас не дописалось в конце в макросе. Ну ладна, если это записью макроса делается, я допишу. Но че то как-то стремно удалять желтые строчки. Он их точно мне сам вставит, где надо?

Добавлено через 5 минут
Pashulka, у вас такая аскетичная изящная формулка, она меня вдохновляет. Но я не совсем понял, вот эти константы — 9, 1 — это относится к типу формул? Просто у меня реально формул больше, и столбцов, в которых надо эти формулы считать, больше. Я не стал утруждать аксакалов, думал, главное — принцип просечь. Если нестандартная какая-нить формула, подойдет ваш метод?

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

05.11.2015, 10:16

Сообщение было отмечено shavka как решение

Решение

shavka, Если посмотрите справку, касательно стандартной функции рабочего листа =ПРОМЕЖУТОЧНЫЕ.ИТОГИ() , то увидите что первый обязательный аргумент — это номер функции, в нашем случае, это 9 — СУММ и 1 — СРЗНАЧ

Если же результаты вычислений не должны зависеть от наличия фильтра(скрытых строк), то ПРОМЕЖУТОЧНЫЕ.ИТОГИ можно заменить на SUM и AVERAGE.

Разумеется, подобным способом Вы можете вводить и более сложные(нестандартные) формулы, только не забудьте, что для программного ввода формул массива — нужно использовать свойство .FormulaArray

132 / 15 / 2

Регистрация: 27.11.2013

Сообщений: 509

05.11.2015, 13:19

[ТС]

Блин, точно, саффсем забыл. FormulaArray! А я просто Formula написал свойство. Потому он и не считает. Спасибо!!!

132 / 15 / 2

Регистрация: 27.11.2013

Сообщений: 509

26.12.2015, 18:36

[ТС]

pashulka, наслаждался вашим изящным макросом и тут вдруг облом: если в каком-либо из списков таблицы всего одна строчка, он дальше не группирует. Ошибка 1004. А если запросить через MsgBox адреса группируемых строк, то в этой единичной строчки он пишет такую билеберду:
$B$1:$L$1,$M$1:$AD$6,$B$2:$C$2,$F$2:$G$2,$J$2:$K$2 ,$B$3:$L$3,$B$4:$C$4,$F$4:$G$4,$J$4:$K$4,
$B$5:$L$6,$Q$7:$AC$7,$A$1:$A$8,$C$8,$J$8:$K$8,$M$8 :$N$8,$Q$8:$AD$912,
$L$9:$P$21,$L$22:$N$22,$L$23:$P$24,$L$25:$N$25,$L$ 26:$P$33,$L$34:$N$34,$L$35:$P$40,$L$41:$N$41. О как!
Никак нельзя это исправить? В принципе, я нашел решение. Просто рассчитываешь номера строк по границам списков, а потом циклом их группируешь через Rows.Group. Но я подозреваю, что это непрофессионально. А я уже чессслово, поверил в ваше всесилие

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

26.12.2015, 19:09

shavka, Не заметил я в своём макросе группировки, но даже ежели её добавить (см.аттач), то если в столбце B будет дата(число) мы пролучим группу, если нет, макрос эту строку просто проигнорирует, но ошибки не будет.

shavka

132 / 15 / 2

Регистрация: 27.11.2013

Сообщений: 509

26.12.2015, 19:22

[ТС]

500 раз спасибо! Точно, я ж сначала хотел просто итоги подсчитать, а потом думаю — нахли мне такая простыня, конца-края не видно, дай-ка загруппирую тем же макросом, но понятым мной несколько извращенно. Но не доперло до меня окончательно, я вот так написал:

Visual Basic

Dim iSour As Range
For Each iSour In Range(Cells(7, 3), Cells(opEnd, 3)).SpecialCells(xlConstants, xlNumbers).Areas
    gr = iSour.SpecialCells(xlConstants, xlNumbers).Address
        Range(gr).Rows.Group
Next iSour

на что макрос высказал мне все, что он обо мне думает

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

26.12.2015, 19:46

На всякий случай — цитата из офисной справки, об’ясняющая когда нужно применять SpecialCells (за исключением xlLastCell) к одной единственной ячейке :

Выделение ячеек в соответствии с содержащимися в них данными

1 Выделите диапазон, содержащий тип ячеек, которые нужно выделить.

Чтобы выделить все ячейки этого типа на текущем листе, наведите указатель на любую ячейку и нажмите кнопку мыши.

2 В меню Правка выберите команду Перейти (мой совет — или используйте клавишу F5)
3 Нажмите кнопку Выделить.
4 Установите нужные параметры.

Источник

This can be accomplished with a simple SUBTOTAL across a dynamic range. Locating Total in column B can be looped.

Option Explicit

Sub totalAllClients()
    Dim rng As Range, rngsb As Range, addr As String

    With Worksheets("sheet11")
        With Intersect(.Columns(2), .UsedRange)
            Set rng = .Find(What:="total", After:=.Cells(1), MatchCase:=False, _
                            LookAt:=xlWhole, SearchDirection:=xlPrevious)
            If Not rng Is Nothing Then
                addr = rng.Address(0, 0)
                Do
                    rng.Offset(0, 1).FormulaR1C1 = _
                        "=index(c2, match(""zzz"", r1c2:r[-1]c2))"
                    rng.Offset(0, 3).Resize(, 6).FormulaR1C1 = _
                        "=subtotal(109, r[-1]c:index(c, match(""zzz"", r1c2:r[-1]c2)))"
                    Set rng = .FindNext(After:=rng)
                Loop Until rng.Address(0, 0) = addr

                rng.Offset(2, 3).Resize(1, 6).FormulaR1C1 = _
                    "=aggregate(9, 3, r2c:r" & rng.Row & "c)"
            End If
        End With
    End With

End Sub

Источник

dimavesna

Пользователь

Сообщений: 21
Регистрация: 02.06.2017

Добрый день. Есть необходимость создать макрос для подсчета промежуточных итогов в таблицах, с разным количеством столбцов.
По умолчанию, для фиксированной ширины таблицы (файл в приложении) Excel записывает вот такой код:

Код
Sub SubTotal() ActiveWindow.SmallScroll Down:=-15 Range("A1").Select Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Selection.SubTotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _ 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, _ 34, 35, 36, 37, 38, 39, 40, 41), Replace:=True, PageBreaks:=False, _ SummaryBelowData:=True End Sub

Код

Sub SubTotal()
    ActiveWindow.SmallScroll Down:=-15
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SubTotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _
        7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, _
        34, 35, 36, 37, 38, 39, 40, 41), Replace:=True, PageBreaks:=False, _
        SummaryBelowData:=True
End Sub

На сколько я понимаю необходимо заменить

Код
TotalList:=Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41)

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

Подскажите пожалуйста как это реализовать. Файл в приложении

Прикрепленные файлы

Test.xlsm (97.89 КБ)

Источник

Промежуточные итоги в таблице

Альбина

Дата: Понедельник, 18.11.2013, 10:01 |
Сообщение № 1

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

Ранг: Новичок

Сообщений: 23

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

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

Здравствуйте уважаемые форумчане. Помогите пожалуйста написать макрос, подводящий промежуточные итоги в таблице.
Есть заполненная таблица (файл прилагается). В ней уже подведены итоги по группам. Необходимо подсчитать промежуточный итог по позициям, в которых заполнено поле признак и в которых данное поле не заполнено. В прилагаемом файле на листе 1 имеющаяся таблица, на листе 2 — как должно быть.

К сообщению приложен файл:

8358190.xls
(26.5 Kb)

Ответить

ABC

Дата: Понедельник, 18.11.2013, 11:42 |
Сообщение № 2

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

Ранг: Обитатель

Сообщений: 397

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

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

Excel 2007

Здравствуйте, через сводную не пробовали?

К сообщению приложен файл:

7320715.xls
(31.0 Kb)

MS Excel 2007 and 2010…
——————————-
С Уважением, Даулет

Ответить

nilem

Дата: Понедельник, 18.11.2013, 11:56 |
Сообщение № 3

Группа: Авторы

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

Сообщений: 1612

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

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

Excel 2013, 2016

или, например, «Данные» — «Пром. итог». Не подходит?

Яндекс.Деньги 4100159601573

Ответить

Альбина

Дата: Понедельник, 18.11.2013, 12:16 |
Сообщение № 4

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

Ранг: Новичок

Сообщений: 23

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

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

Нужен макрос, данные в таблицу загружаются программно, большой объем данных, хотелось бы, чтобы в момент выгрузки сработал VBA и бухгалтер видел промежуточный итог, не производя дополнительных действий.
Понимаю, что возможно включить запись макроса и сделать операцию, подсказанную выше «Данные» — «Пром. итог». Тогда подскажите, какие столбцы нужно при этом выделить, потому что у меня подсчитывается итог по группе а не по признаку.

Ответить

AndreTM

Дата: Понедельник, 18.11.2013, 12:25 |
Сообщение № 5

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

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

Сообщений: 1762

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

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

2003 & 2010

Можно сделать что-то типа такого:
[vba]

Код

Sub test()

i = 2
cPriz = «~»

           Do
         If Cells(i, 1) & Cells(i, 2) <> cPriz And cPriz <> «~» Then
             Rows(i).Insert
             Cells(i, 1) = «Итого с признаком ‘» & Cells(i — 1, 2) & «‘:»
             Cells(i, 1).Resize(, 3).Interior.ColorIndex = 40
             Cells(i, 3) = nSum
             Cells(i, 1).Resize(, 2).Merge
             cPriz = «~»
         Else
             If cPriz = «~» Then
                 nSum = 0
                 If Left(Cells(i, 1), 5) <> «Итого» Then
                     cPriz = Cells(i, 1) & Cells(i, 2)
                 End If
             End If
             If Cells(i, 1) & Cells(i, 2) = cPriz Then
                 nSum = nSum + Cells(i, 3)
             End If
         End If
         i = i + 1
     Loop Until Cells(i, 1) = «»

End Sub

[/vba]

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

Ответить

ABC

Дата: Понедельник, 18.11.2013, 12:26 |
Сообщение № 6

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

Ранг: Обитатель

Сообщений: 397

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

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

Excel 2007

так подойдет?
[vba]

Код

Sub Test()
     Dim arr(), arr2(), i&, y&, it, arr1
     Application.ScreenUpdating = False
     With Sheets(1)
         arr = .Range(«A2:C» & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
     End With
     With CreateObject(«Scripting.Dictionary»)
         For i = LBound(arr, 1) To UBound(arr, 1)
             If arr(i, 1) <> «Итого по группе 1:» Then
                 it = arr(i, 1) & «@@» & arr(i, 2)
                 .Item(it) = .Item(it) + arr(i, 3)
             End If
         Next i

                   ReDim arr2(1 To .Count, 1 To 3)
         y = 1
         For Each it In .Keys
             arr1 = Split(it, «@@»)
             arr2(y, 1) = arr1(0)
             arr2(y, 2) = arr1(1)
             arr2(y, 3) = .Item(it)
             y = y + 1
         Next it
     End With
     With Sheets(3)
         .Cells.Clear
         .[a1].Resize(y — 1, 3).Value = arr2
         .Activate
     End With
     Application.ScreenUpdating = True
End Sub

[/vba]

MS Excel 2007 and 2010…
——————————-
С Уважением, Даулет

Ответить

Альбина

Дата: Понедельник, 18.11.2013, 13:07 |
Сообщение № 7

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

Ранг: Новичок

Сообщений: 23

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

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

Большое спасибо за ответы!
AndreTM. Ваш макрос это именно то, что нужно! Только немного некорректно во второй группе прошел поиск признака ‘X’. Сразу после первой позиции группы 2 с признаком ‘X’ подвелся итог.
В прикрепленном файле результат выполнения макроса.

К сообщению приложен файл:

9327071.xls
(43.0 Kb)

Ответить

Pelena

Дата: Понедельник, 18.11.2013, 13:09 |
Сообщение № 8

Группа: Админы

Ранг: Местный житель

Сообщений: 18797

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

Замечаний:
±

Excel 2016 & Mac Excel

немного некорректно во второй группе прошел поиск признака ‘X’

У Вас данные некорректны: буква Х то русская, то латинская

«Черт возьми, Холмс! Но как??!!»
Ю-money 41001765434816

Ответить

Альбина

Дата: Понедельник, 18.11.2013, 13:17 |
Сообщение № 9

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

Ранг: Новичок

Сообщений: 23

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

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

Да, вы правы, буквы у меня оказались разные. Все работает так, как мне было нужно!
Огромное всем спасибо за помощь!

Ответить

Альбина

Дата: Понедельник, 18.11.2013, 15:05 |
Сообщение № 10

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

Ранг: Новичок

Сообщений: 23

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

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

К сожалению не рассчитала свои силы, слишком упростила документ для примера.
Если можно было бы вернуться к этой теме, помогите пожалуйста.
Исходный файл осложнен тем, что в столбце «Группа» включено объединение ячеек и каждая новая группа отделяется строкой с именем этой группы. Можно ли обойти эти сложности?

К сообщению приложен файл:

9031252.xls
(45.5 Kb)

Ответить

AndreTM

Дата: Понедельник, 18.11.2013, 16:34 |
Сообщение № 11

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

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

Сообщений: 1762

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

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

2003 & 2010

Альбина, и что? Мы теперь будем на каждый чих переписывать код?
Вообще-то, вам выше правильно советовали сразу получить нужный вид сводной, а не напрягать уже готовые таблицы дополнительным функционалом. С другой стороны, вы в макросе разбирались? Или вам (как, между прочим, многим здесь) — «некогда, поскольку начальство напрягает и всё надо ещё вчера»? Так поверьте, многих из нас тоже напрягают — и ничего, успеваем и работать, и новые знания получать, и делиться ими.
Нет, конечно, макрос-то не влом переписать — но ведь там минимум исправлений требуется. Вот только помощь наша уходит в песок… и вы рискуете с таким подходом очень быстро исчерпать запас здешних альтруистов
[vba]

Код

Sub test()

Application.ScreenUpdating = False

i = 17
cPriz = «~»

           Do
         If Cells(i, 2) <> cPriz And cPriz <> «~» Then
             Rows(i).Insert
             Cells(i, 2) = «Итого с признаком ‘» & Cells(i — 1, 2) & «‘:»
             Cells(i, 2).Resize(, 4).Interior.ColorIndex = 36
             Cells(i, 3) = nSum
             ‘Cells(i, 1).Resize(, 2).Merge
             cPriz = «~»
         Else
             If cPriz = «~» Then
                 nSum = 0
                 If Cells(i, 2) = «X» Or Cells(i, 2) = «» Then
                     cPriz = Cells(i, 2)
                 End If
             End If
             If Cells(i, 2) = cPriz Then
                 nSum = nSum + Cells(i, 3)
             End If
         End If
         i = i + 1
     Loop Until Left(Cells(i, 1), 5) = «Всего»

Application.ScreenUpdating = True

End Sub

[/vba]

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

Ответить

Альбина

Дата: Понедельник, 18.11.2013, 16:53 |
Сообщение № 12

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

Ранг: Новичок

Сообщений: 23

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

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

Очень извиняюсь, если я вас обидела. Естественно я разбиралась с макросом. Я потому и выставляла изначально упрощенный вариант, чтобы получить направление, в котором можно разобраться с данной задачей. Я не программист, то, что i = 17, т. к. данные начинаются с 17 строки я поняла, ну и то, что номер столбца может варьироваться, а с объединенными ячейками не разобралась.
Спасибо, что потратили время и помогли мне.

Ответить

Источник