Добрый день, друзья. Необходима ваша помощь. Есть столбец с числами (в виде структуры) 1 2 3 3 2 3 3 3 1 2 3 3 .. и т.д.
Необходимо программно проставить формулы СУММ в зависимости от значения в ячейках (в примере проставил как должно быть) Если 1, то суммируем все двойки до следующей единицы или конца списка. Если 2, то суммируем все тройки до следующей двойки или до конца списка или до единицы.
Буду признателен за помощь или подсказку.
Добрый день, друзья. Необходима ваша помощь. Есть столбец с числами (в виде структуры) 1 2 3 3 2 3 3 3 1 2 3 3 .. и т.д.
Необходимо программно проставить формулы СУММ в зависимости от значения в ячейках (в примере проставил как должно быть) Если 1, то суммируем все двойки до следующей единицы или конца списка. Если 2, то суммируем все тройки до следующей двойки или до конца списка или до единицы.
Sub t() x = [A1:A26].Value For i = UBound(x) To 1 Step -1 Select Case x(i, 1) Case 3: txt2 = txt2 & ",b" & i Case 2: txt1 = txt1 & ",b" & i If txt2 > "" Then Cells(i, "b").Formula = "=sum(" & Mid(txt2, 2) & ")": txt2 = "" Case 1: txt2 = "" If txt1 > "" Then Cells(i, "b") = "=sum(" & Mid(txt1, 2) & ")": txt1 = "": txt2 = "" End Select Next End Sub
[/vba]
пс. вариант чисто учебный - в реальной жизни есть риск нарваться на ограничения по количеству аргументов функции
как вариант [vba]
Код
Sub t() x = [A1:A26].Value For i = UBound(x) To 1 Step -1 Select Case x(i, 1) Case 3: txt2 = txt2 & ",b" & i Case 2: txt1 = txt1 & ",b" & i If txt2 > "" Then Cells(i, "b").Formula = "=sum(" & Mid(txt2, 2) & ")": txt2 = "" Case 1: txt2 = "" If txt1 > "" Then Cells(i, "b") = "=sum(" & Mid(txt1, 2) & ")": txt1 = "": txt2 = "" End Select Next End Sub
[/vba]
пс. вариант чисто учебный - в реальной жизни есть риск нарваться на ограничения по количеству аргументов функцииikki
помощь по Excel и VBA ikki@fxmail.ru, icq 592842413, skype alex.ikki
Сообщение отредактировал ikki - Суббота, 04.01.2014, 17:36
Sub ertert() Dim x, i&, j&, k&, n& With Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row) .Columns(2).ClearContents: x = .Value For i = 1 To UBound(x) If x(i, 1) > 0 Then n = x(i, 1): k = i: j = i Do j = j + 1: If j > UBound(x) Then Exit Do If x(j, 1) = n + 1 Then x(k, 2) = IIf(Len(x(k, 2)), x(k, 2) & ",A" & j, "=SUM(A" & j) Loop While x(j, 1) <> n If Len(x(k, 2)) Then x(k, 2) = x(k, 2) & ")" End If Next i .Value = x End With End Sub
[/vba]
как вариант [vba]
Код
Sub ertert() Dim x, i&, j&, k&, n& With Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row) .Columns(2).ClearContents: x = .Value For i = 1 To UBound(x) If x(i, 1) > 0 Then n = x(i, 1): k = i: j = i Do j = j + 1: If j > UBound(x) Then Exit Do If x(j, 1) = n + 1 Then x(k, 2) = IIf(Len(x(k, 2)), x(k, 2) & ",A" & j, "=SUM(A" & j) Loop While x(j, 1) <> n If Len(x(k, 2)) Then x(k, 2) = x(k, 2) & ")" End If Next i .Value = x End With End Sub
риск нарваться на ограничения по количеству аргументов функции
вариант со сниженным риском (да и просто с диапазонами красивше как-то ) [vba]
Код
Sub t() Dim r1 As Range, r2 As Range, x(), i& x = [A1:A26].Value For i = UBound(x) To 1 Step -1 Select Case x(i, 1) Case 3: If r2 Is Nothing Then Set r2 = Cells(i, 2) Else Set r2 = Union(Cells(i, 2), r2) Case 2 If r1 Is Nothing Then Set r1 = Cells(i, 2) Else Set r1 = Union(Cells(i, 2), r1) If Not r2 Is Nothing Then Cells(i, 2) = "=sum(" & r2.Address(0, 0) & ")": Set r2 = Nothing Case 1 Set r2 = Nothing If Not r1 Is Nothing Then Cells(i, 2) = "=sum(" & r1.Address(0, 0) & ")": Set r1 = Nothing End Select Next End Sub
риск нарваться на ограничения по количеству аргументов функции
вариант со сниженным риском (да и просто с диапазонами красивше как-то ) [vba]
Код
Sub t() Dim r1 As Range, r2 As Range, x(), i& x = [A1:A26].Value For i = UBound(x) To 1 Step -1 Select Case x(i, 1) Case 3: If r2 Is Nothing Then Set r2 = Cells(i, 2) Else Set r2 = Union(Cells(i, 2), r2) Case 2 If r1 Is Nothing Then Set r1 = Cells(i, 2) Else Set r1 = Union(Cells(i, 2), r1) If Not r2 Is Nothing Then Cells(i, 2) = "=sum(" & r2.Address(0, 0) & ")": Set r2 = Nothing Case 1 Set r2 = Nothing If Not r1 Is Nothing Then Cells(i, 2) = "=sum(" & r1.Address(0, 0) & ")": Set r1 = Nothing End Select Next End Sub