Новости
Видео
Microsoft
Windows 10
Железо
Программы
Форум

Имя пользователя:
Пароль:  
Помощь | Регистрация | Забыли пароль?  | Правила  

Компьютерный форум OSzone.net » Сфера Microsoft » Microsoft Office (Word, Excel, Outlook и т.д.) » 2010 - [решено] Excel, расчет процентов

Ответить
Настройки темы
2010 - [решено] Excel, расчет процентов

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


Сообщения: 77
Благодарности: 2

Профиль | Отправить PM | Цитировать

Изменения
Автор: Elizavetta
Дата: 03-10-2016
в экселе 4 таблицы.
2. исходные.
из них нужно сделать такие же как, под ними, т.е. такого же формата.
0 и 1 это категории(да , нет. Возможно несколько)
Группа - это номер группы 1 и 2
нужная таблица имеет вид
28/78(35,9%)
где 28 это n т.е. абсолютное число , 78 это сумма абсолютных значений первой и второй категории 28+50=78.
35,9% это соответствует p (пропорция -0,359 категории 0)

вторая таблица отличается тем, что там добавлены ещё визиты.
групп и визитов может быть несколько
но формат отображения данных такой же
71/78(91%).

каждая из этих двух таблиц представлена отдельно, они не вместе в экселе сопровождаются

Отправлено: 15:46, 07-09-2016

 

Динохромный


Contributor


Сообщения: 690
Благодарности: 317

Профиль | Отправить PM | Цитировать

Elizavetta, первая таблица может быть обработана кодом ниже. Оговорки: как таблицы типа 1 расположены на листе - данных нет, соответственно для работы нужно щелкнуть по любой непустой ячейке внутри таблицы 1, и запустить код - результат будет вставлен ниже нее (соответственно - предусмотрите ниже свободное место, новые строки специальным образом не вставляются, т.к. нет ясности, что правее не будет каких-либо данных). код ищет внутри таблицы слово "Параметр", и строит структуру относительно него, соответственно без этой фразы (или фраза на другом месте) работать не будет.
код для типа 1
Код: Выделить весь код
Public Sub tab_type1()
    Dim TgtCell As Range
    Set TgtCell = ActiveCell.CurrentRegion.Find("Параметр").Offset(7, 0)
    TgtCell.Offset(0, 1).Value = 0
    TgtCell.Offset(0, 1).Resize(1, 2).Merge
    TgtCell.Offset(0, 3).Value = 1
    TgtCell.Offset(0, 3).Resize(1, 2).Merge
    TgtCell.Offset(1, 1).Value = "Группа"
    TgtCell.Offset(1, 1).Resize(1, 2).Merge
    TgtCell.Offset(1, 3).Value = "Группа"
    TgtCell.Offset(1, 3).Resize(1, 2).Merge
    TgtCell.Offset(2, 1).Value = 1
    TgtCell.Offset(2, 2).Value = 2
    TgtCell.Offset(2, 3).Value = 1
    TgtCell.Offset(2, 4).Value = 2
    TgtCell.Offset(3, 0).Value = "Контакт с больным ОРВИ"
    TgtCell.Offset(3, 1).FormulaR1C1 = "=R[-9]C[1] & ""/"" & (R[-9]C[1]+R[-9]C[3]) & ""("" & ROUND(100*R[-9]C[1]/(R[-9]C[1]+R[-9]C[3]),1) & ""%)"""
    TgtCell.Offset(3, 2).FormulaR1C1 = "=R[-8]C & ""/"" & (R[-8]C+R[-8]C[2]) & ""("" & ROUND(100*R[-8]C/(R[-8]C+R[-8]C[2]),1) & ""%)"""
    
    TgtCell.Offset(3, 3).FormulaR1C1 = "=R[-9]C[1] & ""/"" & (R[-9]C[-1]+R[-9]C[1]) & ""("" & ROUND(100*R[-9]C[1]/(R[-9]C[-1]+R[-9]C[1]),1) & ""%)"""
    
    TgtCell.Offset(3, 4).FormulaR1C1 = "=R[-8]C & ""/"" & (R[-8]C[-2]+R[-8]C) & ""("" & ROUND(100*R[-8]C/(R[-8]C[-2]+R[-8]C),1) & ""%)"""
    With TgtCell.CurrentRegion.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Set TgtCell = Nothing
End Sub

Цитата Elizavetta:
вторая таблица »
Честно говоря - принципа формирования результата по второй таблице не понял. Желательно расписать формулами, как получаются эти значения, а вставку этих формул автоматизировать на VBA.
Это сообщение посчитали полезным следующие участники:

Отправлено: 12:16, 08-09-2016 | #2



Для отключения данного рекламного блока вам необходимо зарегистрироваться или войти с учетной записью социальной сети.

Если же вы забыли свой пароль на форуме, то воспользуйтесь данной ссылкой для восстановления пароля.


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


Сообщения: 77
Благодарности: 2

Профиль | Отправить PM | Цитировать

a_axe, Спасибо Вам, вторую таблицу, где визиты, расписала по формулам, используя функцию СЦЕПИТЬ.
вид должен быть такой
n/N(%)

N считается как сумма n
1 группа N=n+n =78
2 группа N=n+n =100

в первой группе у нас 2 категории n1=71 и n2=7 => N=78, т.е. 71 нет+ 7 да.
Я в файле пометки сделала, посмотрите пожалуйста.

Ваш код для первой таблицы сработал на ура. НО! он не работает для дополнительных категорий и параметров, которых может быть несколько. Привела пример

Касательно второй таблицы там также может быть
-несколько групп
-несколько категорий
-несколько визитов

Последний раз редактировалось Elizavetta, 03-10-2016 в 15:36.

Отправлено: 16:45, 08-09-2016 | #3


Динохромный


Contributor


Сообщения: 690
Благодарности: 317

Профиль | Отправить PM | Цитировать

Цитата Elizavetta:
он не работает для дополнительных категорий и параметров, которых может быть несколько. »
Elizavetta, поправил код, при этом пришлось уйти от формул в ячейках. Работает с двумя визитами, поправлять под произвольное число сейчас к сожалению катастрофически нет времени. Как вариант - таблицу можно разбить на несколько и использовать код.
код
Код: Выделить весь код
Public Sub tab_type1v2()
    Dim dataRng As Range, TgtCell As Range, parRng As Range, sumRng As Range, offsRng As Range
    Dim i As Long, j As Long
    Dim strFormula As String
    Set dataRng = ActiveCell.CurrentRegion
    Set parRng = dataRng.Find("Параметр").Offset(0, 2).Resize(1, dataRng.Columns.Count - 2)
    Set TgtCell = dataRng.Find("Параметр").Offset(dataRng.Rows.Count + 3, 0)
    For j = 1 To (dataRng.Rows.Count - 2) \ 2
        Set sumRng = parRng.Offset(j * 2 - 1, 0)
        TgtCell.Offset(j + 2, 0).Value = Cells(sumRng.Row, dataRng.Column).Value
        For i = 0 To (parRng.Columns.Count - 1) \ 2
            If j = 1 Then
                TgtCell.Offset(0, 2 * i + 1).Value = i
                TgtCell.Offset(0, 2 * i + 1).Resize(1, 2).Merge
                TgtCell.Offset(1, 2 * i + 1).Value = "Группа"
                TgtCell.Offset(1, 2 * i + 1).Resize(1, 2).Merge
                TgtCell.Offset(2, 2 * i + 1).Value = 1
                TgtCell.Offset(2, 2 * i + 2).Value = 2
            End If
 TgtCell.Offset(2 + j, 2 * i + 1).Value = sumRng.Resize(1, 1).Offset(0, 2 * i).Value & "/" & Application.WorksheetFunction.SumIf(parRng, "=n", sumRng) & "(" & Format(100 * sumRng.Resize(1, 1).Offset(0, 2 * i).Value / Application.WorksheetFunction.SumIf(parRng, "=n", sumRng), "0.00") & "%)"
  TgtCell.Offset(2 + j, 2 * i + 2).Value = sumRng.Resize(1, 1).Offset(1, 2 * i).Value & "/" & Application.WorksheetFunction.SumIf(parRng, "=n", sumRng.Offset(1, 0)) & "(" & Format(100 * sumRng.Resize(1, 1).Offset(1, 2 * i).Value / Application.WorksheetFunction.SumIf(parRng, "=n", sumRng.Offset(1, 0)), "0.00") & "%)"
 
        Next
    Next
    
    
    
    
  
    
    With TgtCell.CurrentRegion.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Set TgtCell = Nothing
    Set dataRng = Nothing
    Set sumRng = Nothing
End Sub


Добавлено:
поправил код, теперь работает для любого количества групп (по крайней мере у меня - предлагаю проверить сначала на нескольких реальных примерах). В таблицах обязательно нужно проставить нумерацию групп, как в ваших примерах.
Универсальный код для таблиц типа 1
Код: Выделить весь код
Public Sub tab_type1v3()
    Dim dataRng As Range, TgtCell As Range, parRng As Range, sumRng As Range, offsRng As Range
    Dim i As Long, j As Long, n As Integer, k As Integer
    Dim strFormula As String
    
    
    Set dataRng = ActiveCell.CurrentRegion
    Set parRng = dataRng.Find("Параметр").Offset(0, 2).Resize(1, dataRng.Columns.Count - 2)
    Set TgtCell = dataRng.Find("Параметр").Offset(dataRng.Rows.Count + 3, 0)
    
    n = Application.WorksheetFunction.Max(dataRng.Columns.Item(2))
    
    For j = 1 To (dataRng.Rows.Count - 2) \ n
        Set sumRng = parRng.Offset(j * n - n + 1, 0)
        TgtCell.Offset(j + 2, 0).Value = Cells(sumRng.Row, dataRng.Column).Value
        For i = 0 To (parRng.Columns.Count - 1) \ 2
            
            If j = 1 Then
                TgtCell.Offset(0, n * i + 1).Value = i
                TgtCell.Offset(0, n * i + 1).Resize(1, n).Merge
                TgtCell.Offset(1, n * i + 1).Value = "Группа"
                TgtCell.Offset(1, n * i + 1).Resize(1, n).Merge
                For k = 1 To n
                    TgtCell.Offset(2, n * i + k).Value = k
                Next k
            End If
            For k = 0 To n - 1
                TgtCell.Offset(2 + j, n * i + 1 + k).Value = sumRng.Resize(1, 1).Offset(k, 2 * i).Value & "/" & Application.WorksheetFunction.SumIf(parRng, "=n", sumRng.Offset(k, 0)) & "(" & Format(100 * sumRng.Resize(1, 1).Offset(k, 2 * i).Value / Application.WorksheetFunction.SumIf(parRng, "=n", sumRng.Offset(k, 0)), "0.00") & "%)"
                
            Next k
            
        Next
    Next
    
    
    
    
  
    
    With TgtCell.CurrentRegion.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Set TgtCell = Nothing
    Set dataRng = Nothing
    Set sumRng = Nothing
End Sub

Updated:
Для таблиц типа 2 можно использовать код ниже. Оговорки: также необходимо выделить любую непустую ячейку в таблице. В столбце "Параметр" имя параметра должно быть указано строго как в примере - один раз для каждой группы, остальные ячейки пустые (они заполняться в процессе работы кода). Аналогично "группа" - указывается один раз (вроде это не имеет принципиального значения, однако лучше строго оформлять так, как в примере). Визиты должны быть четко пронумерованы без пустых ячеек. К сожалению, код крайне чувствителен к указанному оформлению. Таблицу на выходе я немного переоформил, полагаю - это не критично.
Код для таблиц типа 2:
Код: Выделить весь код
Public Sub tab_type2v1()
    
    Dim i As Long, strListName As String
    Dim j As Long, n As Integer, k As Integer, n1 As Integer, n2 As Integer
    
    Dim dataRng As Range, curRng As Range
    
    Set dataRng = ActiveCell.CurrentRegion.Find("Параметр")
    dataRng.Offset(0, 3) = "n1"
    dataRng.Offset(0, 4) = "p1"
    dataRng.Offset(0, 5) = "n2"
    dataRng.Offset(0, 6) = "p2"
    Set dataRng = Range(dataRng, Cells(ActiveCell.CurrentRegion.Row + ActiveCell.CurrentRegion.Rows.Count - 1, ActiveCell.CurrentRegion.Column + ActiveCell.CurrentRegion.Columns.Count - 1))
    
    
    strListName = ActiveSheet.ListObjects.Add(xlSrcRange, dataRng, , xlYes).Name
    
    
    Set dataRng = Nothing
    
    Dim Npar As Integer, Nviz As Integer, Ngr As Integer
    Nviz = Application.WorksheetFunction.Max(Range(strListName & "[Визит]"))
    Ngr = Application.WorksheetFunction.Max(Range(strListName & "[Группа]"))
    Npar = Application.WorksheetFunction.CountA(Range(strListName & "[Параметр]")) \ Ngr
    Dim TgtCell As Range
    Set TgtCell = Range(strListName).Resize(1, 1).Offset(Range(strListName).Rows.Count + 5, 0)
    TgtCell.Value = "Визит"
    TgtCell.Offset(1, 0).Value = "Группа"
    TgtCell.Offset(2, 0).Value = "Параметр"
    For k = 1 To Npar
        TgtCell.Offset(2 + k, 0).Value = Range(strListName & "[Параметр]").Rows(1 + (k - 1) * Nviz * Ngr).Value
    Next k
    
    For Each curRng In Range(strListName).Columns(1).Resize(, 2).Cells
        If IsEmpty(curRng.Value) Then curRng.FormulaR1C1 = "=r[-1]c"
    Next curRng
    
    For i = 1 To Nviz
        
        Range(TgtCell.Offset(0, 1 + (i - 1) * 2 * Ngr), TgtCell.Offset(0, i * 2 * Ngr)).Value = i
        For j = 1 To Ngr
            
            TgtCell.Offset(1, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Resize(1, 2).Value = j
            TgtCell.Offset(2, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value = "нет"
            TgtCell.Offset(2, 2 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value = "да"
            For k = 1 To Npar
                
                
                TgtCell.Offset(k + 2, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).FormulaR1C1 = "=SUMPRODUCT((" & strListName & "[Параметр]=" & Chr(34) & TgtCell.Offset(2 + k, 0).Value & Chr(34) & ")*(" & strListName & "[Группа]=R[" & (-1 - k) & "]C)*(" & strListName & "[Визит]=R[" & (-2 - k) & "]C)*" & strListName & "[n1])"
                TgtCell.Offset(k + 2, 2 + (i - 1) * 2 * Ngr + 2 * (j - 1)).FormulaR1C1 = "=SUMPRODUCT((" & strListName & "[Параметр]=" & Chr(34) & TgtCell.Offset(2 + k, 0).Value & Chr(34) & ")*(" & strListName & "[Группа]=R[" & (-1 - k) & "]C[-1])*(" & strListName & "[Визит]=R[" & (-2 - k) & "]C[-1])*" & strListName & "[n2])"
                
                
                n1 = TgtCell.Offset(k + 2, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value
                n2 = TgtCell.Offset(k + 2, 2 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value
                
                
                TgtCell.Offset(k + 2, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value = n1 & "/" & (n1 + n2) & "(" & Format(n1 / (n1 + n2) * 100, "0.0") & "%)"
                TgtCell.Offset(k + 2, 2 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value = n2 & "/" & (n1 + n2) & "(" & Format(n2 / (n1 + n2) * 100, "0.0") & "%)"
            Next k
        Next j
        
    Next i
    
    
    
    Application.DisplayAlerts = False
    For i = 1 To Nviz
        Range(TgtCell.Offset(0, 1 + (i - 1) * 2 * Ngr), TgtCell.Offset(0, i * 2 * Ngr)).Merge
        For j = 1 To Ngr
            
            TgtCell.Offset(1, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Resize(1, 2).Merge
            
        Next j
        
    Next i
    Application.DisplayAlerts = True
    TgtCell.CurrentRegion.HorizontalAlignment = xlCenter
    
    With TgtCell.CurrentRegion.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Set TgtCell = Nothing
    
    
End Sub

Последний раз редактировалось a_axe, 22-09-2016 в 13:37.

Это сообщение посчитали полезным следующие участники:

Отправлено: 21:09, 11-09-2016 | #4


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


Сообщения: 77
Благодарности: 2

Профиль | Отправить PM | Цитировать

a_axe, с первой таблицей, 2 дня тестировала, вопросов нет) А для второй таблички визитной, код не сработал почему-то(

Отправлено: 14:20, 15-09-2016 | #5


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


Сообщения: 77
Благодарности: 2

Профиль | Отправить PM | Цитировать

a_axe, а вы можете дать ваш эксель.
Я все сделала ,как Вы сказали. Результат выложила. выделила ячейку b4, запустила макрос и вот.

Последний раз редактировалось Elizavetta, 03-10-2016 в 15:36.

Отправлено: 21:43, 24-09-2016 | #6


Динохромный


Contributor


Сообщения: 690
Благодарности: 317

Профиль | Отправить PM | Цитировать

Elizavetta, я исходил из вашей первой таблицы "реструктуризация" - в ней один параметр ("головокружение.0.нет..1.да") и для этого параметра две группы (№1 и №2).

В последнем примере - параметров уже два, а с группами непонятки - параметру "температура" соответствует группа 1, параметру "озноб" - группа 2. Исходя из логики вашего первого примера, должно быть:
либо группа одна (№1) для обоих параметров,
либо две (№1 и №2) для обоих параметров, причем опять же как в вашем предыдущем примере - сначала две группы для первого параметра, потом две группы для второго и т.д.

Замените в вашем последнем примере группу 2 на группу 1, и все будет работать. Алгоритм заложен именно такой. Файла, на котором все тестировалось под рукой нет, однако структура была для примера следующая:
Два параметра, для каждого две группы, для них четыре визита. Сначала перечислены все визиты, для каждого визита все группы, для них - визиты. Обратите внимание на пустые ячейки в визитах - их необходимо соблюдать (как в вашем примере).
Картинка


Если последняя структура верная,
1. то получается что "Параметр" и "Группа" просто-напросто синонимы, и одно из них не нужно рассматривать.
2. предлагаю вам вручную заполнить таблицу результата, чтобы я понял, что должна выдать программа.
3. выложить еще несколько примеров с результатом.


Updated:
По раздумью, код можно изменить так, что он будет работать при любом раскладе, кроме того - теперь необязательно наличие пустых ячеек в структуре. Потестируйте и отпишитесь (разумеется - после ответа на вопросы, приведенные выше).
Код для реструктуризации N2
Код: Выделить весь код
Public Sub tab_type2v2()
    
    Dim i As Long, strListName As String
    Dim j As Long, n As Integer, k As Integer, n1 As Integer, n2 As Integer
    
    Dim dataRng As Range, curRng As Range
    
    Set dataRng = ActiveCell.CurrentRegion.Find("Параметр")
    dataRng.Offset(0, 3) = "n1"
    dataRng.Offset(0, 4) = "p1"
    dataRng.Offset(0, 5) = "n2"
    dataRng.Offset(0, 6) = "p2"
    Set dataRng = Range(dataRng, Cells(ActiveCell.CurrentRegion.Row + ActiveCell.CurrentRegion.Rows.Count - 1, ActiveCell.CurrentRegion.Column + ActiveCell.CurrentRegion.Columns.Count - 1))
    
    
    strListName = ActiveSheet.ListObjects.Add(xlSrcRange, dataRng, , xlYes).Name
    
    
    Set dataRng = Nothing
    
    Dim Npar As Integer, Nviz As Integer, Ngr As Integer
    Nviz = Application.WorksheetFunction.Max(Range(strListName & "[Визит]"))
    Ngr = Application.WorksheetFunction.Max(Range(strListName & "[Группа]"))
    'Npar = Application.WorksheetFunction.CountA(Range(strListName & "[Параметр]")) \ Ngr
    Dim TgtCell As Range
    Set TgtCell = Range(strListName).Resize(1, 1).Offset(Range(strListName).Rows.Count + 5, 0)
    TgtCell.Value = "Визит"
    TgtCell.Offset(1, 0).Value = "Группа"
    TgtCell.Offset(2, 0).Value = "Параметр"
'    For k = 1 To Npar
'        TgtCell.Offset(2 + k, 0).Value = Range(strListName & "[Параметр]").Rows(1 + (k - 1) * Nviz * Ngr).Value
'    Next k

    For Each curRng In Range(strListName).Columns(1).Cells
        If Not IsEmpty(curRng.Value) Then
        If TgtCell.CurrentRegion.Columns(1).Find(curRng.Value) Is Nothing Then _
        TgtCell.Offset(TgtCell.CurrentRegion.Rows.Count, 0).Value = curRng.Value
        Else
        curRng.FormulaR1C1 = "=r[-1]c"
        End If
    Next curRng
    Npar = TgtCell.CurrentRegion.Rows.Count - 3
        For Each curRng In Range(strListName).Columns(1).Resize(, 2).Cells
            If IsEmpty(curRng.Value) Then curRng.FormulaR1C1 = "=r[-1]c"
        
        Next curRng
    
    For i = 1 To Nviz
        
        Range(TgtCell.Offset(0, 1 + (i - 1) * 2 * Ngr), TgtCell.Offset(0, i * 2 * Ngr)).Value = i
        For j = 1 To Ngr
            
            TgtCell.Offset(1, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Resize(1, 2).Value = j
            TgtCell.Offset(2, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value = "нет"
            TgtCell.Offset(2, 2 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value = "да"
            For k = 1 To Npar
                
                
                TgtCell.Offset(k + 2, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).FormulaR1C1 = "=SUMPRODUCT((" & strListName & "[Параметр]=" & Chr(34) & TgtCell.Offset(2 + k, 0).Value & Chr(34) & ")*(" & strListName & "[Группа]=R[" & (-1 - k) & "]C)*(" & strListName & "[Визит]=R[" & (-2 - k) & "]C)*" & strListName & "[n1])"
                TgtCell.Offset(k + 2, 2 + (i - 1) * 2 * Ngr + 2 * (j - 1)).FormulaR1C1 = "=SUMPRODUCT((" & strListName & "[Параметр]=" & Chr(34) & TgtCell.Offset(2 + k, 0).Value & Chr(34) & ")*(" & strListName & "[Группа]=R[" & (-1 - k) & "]C[-1])*(" & strListName & "[Визит]=R[" & (-2 - k) & "]C[-1])*" & strListName & "[n2])"
                
                
                n1 = TgtCell.Offset(k + 2, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value
                n2 = TgtCell.Offset(k + 2, 2 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value
                
                If n1 <> 0 Then
                    TgtCell.Offset(k + 2, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value = n1 & "/" & (n1 + n2) & "(" & Format(n1 / (n1 + n2) * 100, "0.0") & "%)"
                    TgtCell.Offset(k + 2, 2 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Value = n2 & "/" & (n1 + n2) & "(" & Format(n2 / (n1 + n2) * 100, "0.0") & "%)"
                End If
            Next k
        Next j
        
    Next i
    
    
    
    Application.DisplayAlerts = False
    For i = 1 To Nviz
        Range(TgtCell.Offset(0, 1 + (i - 1) * 2 * Ngr), TgtCell.Offset(0, i * 2 * Ngr)).Merge
        For j = 1 To Ngr
            
            TgtCell.Offset(1, 1 + (i - 1) * 2 * Ngr + 2 * (j - 1)).Resize(1, 2).Merge
            
        Next j
        
    Next i
    Application.DisplayAlerts = True
    TgtCell.CurrentRegion.HorizontalAlignment = xlCenter
    
    With TgtCell.CurrentRegion.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With TgtCell.CurrentRegion.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Set TgtCell = Nothing
    
    
End Sub

Последний раз редактировалось a_axe, 25-09-2016 в 09:09.

Это сообщение посчитали полезным следующие участники:

Отправлено: 08:35, 25-09-2016 | #7


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


Сообщения: 77
Благодарности: 2

Профиль | Отправить PM | Цитировать

Все теперь нормально. Дело в том, что параметров то может быть много. А смысл Вас тревожить ради оформления 2 параметров, я бы сама сделала, чтоб Ваше время не тратить, я просто 2 параметра привела как образец.

Отправлено: 13:49, 25-09-2016 | #8


Динохромный


Contributor


Сообщения: 690
Благодарности: 317

Профиль | Отправить PM | Цитировать

Цитата Elizavetta:
Дело в том, что параметров то может быть много. »
Elizavetta, предыдущий код также работал с любым количеством параметров - хоть 10, хоть 35. Эта часть кода вообще никак не поменялась.

Ограничение было в другом: для каждого параметра набор групп должен был одинаков - пусть групп будет 10, но их должно быть 10 для каждого параметра. Во второй версии кода если код не находит для параметра какую-либо из групп, он пишет нулевое значение (до этого отсутствие любой из групп для любого из параметров код считал ошибкой).

Применительно к последнему вашему примеру - групп у вас две, код не находил вторую группу для первого параметра и аварийно останавливался. Для второго параметра отсутствует группа 1, это он бы также расценивал как ошибку.

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

Последний раз редактировалось a_axe, 26-09-2016 в 14:20.

Отправлено: 14:48, 25-09-2016 | #9



Компьютерный форум OSzone.net » Сфера Microsoft » Microsoft Office (Word, Excel, Outlook и т.д.) » 2010 - [решено] Excel, расчет процентов

Участник сейчас на форуме Участник сейчас на форуме Участник вне форума Участник вне форума Автор темы Автор темы Шапка темы Сообщение прикреплено

Похожие темы
Название темы Автор Информация о форуме Ответов Последнее сообщение
2010 - [решено] Word, авторасчет процентов Elizavetta Microsoft Office (Word, Excel, Outlook и т.д.) 4 07-09-2016 15:14
Загрузка - [решено] Загруженность процессора 90-100 процентов. kost9413 Microsoft Windows 7 8 07-04-2013 11:58
Разное - Параллельный расчет Excel-Word Frnk Microsoft Office (Word, Excel, Outlook и т.д.) 1 09-12-2011 15:44
Дефицит жестких дисков составляет 35 процентов OSZone News Новости железа 8 29-11-2011 18:42
20 процентов американцев пользуются Twitter OSZone News Новости информационных технологий 0 23-10-2009 22:30


« Предыдущая тема | Следующая тема »


 
Переход