Компьютерный форум OSzone.net  

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)
-   Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)
-   -   [решено] Excel, расчет процентов (http://forum.oszone.net/showthread.php?t=318562)

Elizavetta 07-09-2016 15:46 2666542
Excel, расчет процентов
 
в экселе 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%).

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

a_axe 08-09-2016 12:16 2666746
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.

Elizavetta 08-09-2016 16:45 2666819
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 да.
Я в файле пометки сделала, посмотрите пожалуйста.

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

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

a_axe 11-09-2016 21:09 2667703
Цитата:
Цитата 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

Elizavetta 15-09-2016 14:20 2668816
a_axe, с первой таблицей, 2 дня тестировала, вопросов нет) А для второй таблички визитной, код не сработал почему-то:((

Elizavetta 24-09-2016 21:43 2671875
a_axe, а вы можете дать ваш эксель.
Я все сделала ,как Вы сказали. Результат выложила. выделила ячейку b4, запустила макрос и вот.

a_axe 25-09-2016 08:35 2671945
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

Elizavetta 25-09-2016 13:49 2671987
Все теперь нормально. :) Дело в том, что параметров то может быть много. А смысл Вас тревожить ради оформления 2 параметров, я бы сама сделала, чтоб Ваше время не тратить, я просто 2 параметра привела как образец.

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

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

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

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


Время: 22:23.

Время: 22:23.
© OSzone.net 2001-