VBA, чтобы добавить строку под общей строкой, которая рассчитывает процент от общей суммы

Question

У меня есть набор данных, который вычисляет итоги для каждого изменения в группировке для 3 категорий. Мне нужно вставить строку под строкой итогов, чтобы рассчитать процент от общего количества для тех же трех полей. Существует разное количество строк для каждого изменения в группировке.

Я использовал следующий код для вставки строки:

Sub insert percent row()
Dim c As Range

For Each c In Range("Q1:Q100")
  If c.Value Like "*Total*" Then
    c.Offset(1, 0).EntireRow.Insert
  End If
Next c

End Sub

Я застрял на том, что делать дальше.

Мой итог указан в столбце Q, а три ячейки - в столбцах Y, Z и AA. Мне нужно вставить Y / Y + Z + AA, Z / Y + Z + AA, AA / Y + Z + AA ниже их итогов и отформатировать в процентах. В идеале я бы хотел, чтобы это выглядело так:

    A        Q               Y    Z    AA
    Item 1   Group 1         1
    Item 2   Group 1         1
    Item 3   Group 1              2
    Item 4   Group 1              2
    Item 5   Group 1                   4
             Group 1 Total   2    4    4
             Group 1 Percent 20%  40%  40%

Answer 1

В итоге я не получил желаемый результат через VBA. Я запустил код, который я первоначально разместил, чтобы добавить пустую строку после моей строки «Всего». Затем я сделал следующее с формулами:

1. Добавить в столбцы после Q, Y, Z, AA
2. В столбец R добавить формулу = IF (Q2 = "", OFFSET (Q2, -2,0) & "Percent", "No")
3. В столбец AA добавить формулу = ТЕКСТ (ЕСЛИ (ЕЧИСЛО (ПОИСК ( "Процент", R2)), Z 1 / (z1 + АВ1 + АД1), "Нет"), "# 0%")
4. В столбец AC добавить формулу = ТЕКСТ (ЕСЛИ (ЕЧИСЛО (ПОИСК ( "Процент", R2)), АВ1 / (z1 + АВ1 + АД1), "Нет"), "# 0%")
5. В столбец AE добавить формулу = ТЕКСТ (ЕСЛИ (ЕЧИСЛО (ПОИСК ( "Процент", R2)), АД1 / (z1 + АВ1 + АД1), "Нет"), "# 0%")
6. Преобразовать все формулы в значения
7. Фильтр по ячейкам, которые содержат «Процент» в столбце R
8. Перетащите ячейки «Проценты» в пустые ячейки в столбце Q
9. Отфильтровать ячейки "Нет" в столбце AA
10. Перетащите процентные ячейки из AA в пустые ячейки в столбце Z
11. Перетащите процентные ячейки из AC в пустые ячейки в столбце AB
12. Перетащите процентные ячейки из AD в пустые ячейки в столбце AD
13. Удалить столбцы R, AA, AC, AE

Answer 2

Попробуйте этот код.Предполагается, что ваш итог находится в столбце X.

Sub Macro1()

    Dim EmptyFields As Integer
    Dim MyRow As Integer
    Dim GrandTotal As Integer

    Dim Percent1, Percent2, Percent3 As Double
    EmptyFields = 0
    MyRow = 1

    ' if 3 continuous cells are empty, we should assume that the dataset is over
    Do While EmptyFields < 3

        Range("X" & MyRow).Select

        ' if we see Total in column X, we should get grand total of that row
        ' and caculate percentages. Then, we add a new row below it
        ' and store the percentages in the new row
        If LCase(Range("X" & MyRow).Text) = "total" Then
            GrandTotal = Range("Y" & MyRow).Value + Range("Z" & MyRow).Value + Range("AA" & MyRow).Value
            Percent1 = Round(Range("Y" & MyRow).Value * 100 / GrandTotal)
            Percent2 = Round(Range("Z" & MyRow).Value * 100 / GrandTotal)
            Percent3 = Round(Range("AA" & MyRow).Value * 100 / GrandTotal)

            Range("X" & MyRow + 1).Select
            Selection.EntireRow.Insert , copyorigin:=xlFormatFromLeftOrAbove
            Range("X" & MyRow + 1).Select
            ActiveCell.FormulaR1C1 = "Percent"
            Range("Y" & MyRow + 1).Select
            ActiveCell.FormulaR1C1 = Str(Percent1) & "%"
            Range("Z" & MyRow + 1).Select
            ActiveCell.FormulaR1C1 = Str(Percent2) & "%"
            Range("AA" & MyRow + 1).Select
            ActiveCell.FormulaR1C1 = Str(Percent3) & "%"

            EmptyFields = 0
            MyRow = MyRow + 1

        ' if cell is empty, increment empty fields variable
        ElseIf Len(Trim(Range("X" & MyRow).Text)) = 0 Then
            EmptyFields = EmptyFields + 1
        Else
            EmptyFields = 0
        End If

        MyRow = MyRow + 1
    Loop

End Sub

На основе обновленного требования попробуйте этот код:

Sub Macro1()

    Dim EmptyFields, MyRow, GrandTotal As Integer
    Dim Percent1, Percent2, Percent3 As Double
    Dim TotalLabel As String
    EmptyFields = 0
    MyRow = 1

    ' if 3 continuous cells are empty, we should assume that the dataset is over
    Do While EmptyFields < 3

        Range("Q" & MyRow).Select
        TotalLabel = Range("Q" & MyRow).Text

        ' if we see Total in column X, we should get grand total of that row
        ' and caculate percentages. Then, we add a new row below it
        ' and store the percentages in the new row
        If InStr(LCase(TotalLabel), "total") > 0 Then
            GrandTotal = Range("Y" & MyRow).Value + Range("Z" & MyRow).Value + Range("AA" & MyRow).Value
            Percent1 = Round(Range("Y" & MyRow).Value * 100 / GrandTotal)
            Percent2 = Round(Range("Z" & MyRow).Value * 100 / GrandTotal)
            Percent3 = Round(Range("AA" & MyRow).Value * 100 / GrandTotal)

            Range("Q" & MyRow + 1).Select
            Selection.EntireRow.Insert , copyorigin:=xlFormatFromLeftOrAbove
            Range("Q" & MyRow + 1).Select
            ActiveCell.FormulaR1C1 = Replace(LCase(TotalLabel), "total", "Percent")
            Range("Y" & MyRow + 1).Select
            ActiveCell.FormulaR1C1 = Str(Percent1) & "%"
            Range("Z" & MyRow + 1).Select
            ActiveCell.FormulaR1C1 = Str(Percent2) & "%"
            Range("AA" & MyRow + 1).Select
            ActiveCell.FormulaR1C1 = Str(Percent3) & "%"

            EmptyFields = 0
            MyRow = MyRow + 1

        ' if cell is empty, increment empty fields variable
        ElseIf Len(Trim(Range("Q" & MyRow).Text)) = 0 Then
            EmptyFields = EmptyFields + 1
        Else
            EmptyFields = 0
        End If

        MyRow = MyRow + 1
    Loop

End Sub