[решено] Excel, расчет процентов

[Elizavetta]

в экселе 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]

Elizavetta, первая таблица может быть обработана кодом ниже. Оговорки: как таблицы типа 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
вторая таблица »
Честно говоря - принципа формирования результата по второй таблице не понял. Желательно расписать формулами, как получаются эти значения, а вставку этих формул автоматизировать на VBA.

[Elizavetta]

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]

он не работает для дополнительных категорий и параметров, которых может быть несколько. »
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



Добавлено:
поправил код, теперь работает для любого количества групп (по крайней мере у меня - предлагаю проверить сначала на нескольких реальных примерах). В таблицах обязательно нужно проставить нумерацию групп, как в ваших примерах.
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 можно использовать код ниже. Оговорки: также необходимо выделить любую непустую ячейку в таблице. В столбце "Параметр" имя параметра должно быть указано строго как в примере - один раз для каждой группы, остальные ячейки пустые (они заполняться в процессе работы кода). Аналогично "группа" - указывается один раз (вроде это не имеет принципиального значения, однако лучше строго оформлять так, как в примере). Визиты должны быть четко пронумерованы без пустых ячеек. К сожалению, код крайне чувствителен к указанному оформлению. Таблицу на выходе я немного переоформил, полагаю - это не критично.
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]

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

[Elizavetta]

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

[a_axe]

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

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

Замените в вашем последнем примере группу 2 на группу 1, и все будет работать. Алгоритм заложен именно такой. Файла, на котором все тестировалось под рукой нет, однако структура была для примера следующая:
Два параметра, для каждого две группы, для них четыре визита. Сначала перечислены все визиты, для каждого визита все группы, для них - визиты. Обратите внимание на пустые ячейки в визитах - их необходимо соблюдать (как в вашем примере).
http://s41.radikal.ru/i093/1609/89/d90a7ca73e1c.jpg

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


Updated:
По раздумью, код можно изменить так, что он будет работать при любом раскладе, кроме того - теперь необязательно наличие пустых ячеек в структуре. Потестируйте и отпишитесь (разумеется - после ответа на вопросы, приведенные выше).
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]

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

[a_axe]

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

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

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

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