Добрый день. Подскажите, пожалуйста, как можно решить подобную задачу...
Во вложении файлик. Там две таблички для примера: Источник и Обработанный. Нужно чтобы табличка Источник после обработки стала как табличка Обработанный, а именно - по первому столбцу, если там написано "Итого", то в остальных столбцах должна вставиться формула суммы значений выше (до предыдущей строчки с "Итого"). Т.е. там, где красные цыфры должны быть формулы суммы (первоначально в Источнике стоят значения). Естественно, размерность таблицы может менятся по стокам (разный набор данных), но по столбцам формат не меняется. Хотелось бы записать макрос, т.к. с подобными выгрузками приходиться работать довольно часто.
Подскажите, если кто сталкивался с подобным. Спасибо!
Sub ПроставитьСУММ()
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Dim y As Long
y = .Cells(.Rows.Count, 1).End(xlUp).Row
If y = 1 Then Exit Sub
Dim arr As Variant
arr = .Range(.Cells(1, 1), .Cells(y, 1))
Dim u As Long
u = 1
For y = 1 To UBound(arr, 1)
Select Case arr(y, 1)
Case 1
u = y + 1
Case "ИТОГО"
If y > u + 1 Then
.Cells(y, 2).Resize(1, 3).FormulaR1C1 = "=SUM(R[-" & y - u & "]C:R[-1]C)"
End If
u = y + 1
End Select
Next
End With
End Sub
Вариант названия темы Проставить =СУММ() в строки, содержащие ИТОГО
Изменено: МатросНаЗебре - 15.06.2021 17:12:32(Добавил название темы после сообщения от Джека Известного.)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, а я не могу уже поменять тему? название: "Проставить =СУММ() в строки, содержащие ИТОГО" - звучит логичнее
МатросНаЗебре, спасибо большое! Но видимо зря я скинул приблизительный файл. теперь без комментариев в коде не могу применить к своему рабочему файлу((( если вдруг есть свободная минутка, можете адаптировать код под живой пример? суммы нужны в столбцах 7, 8, 9, 10 и 11 по условию в 5-ом столбце "ИТОГО:"
Щёлкаю F8 и смотрю в Locals как баран на новые ворота хотя операторы вроде все знакомые
Sub ПроставитьСУММ()
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Dim y As Long
y = .Cells(.Rows.Count, 5).End(xlUp).Row
If y = 1 Then Exit Sub
Dim arr As Variant
arr = .Range(.Cells(1, 5), .Cells(y, 5))
Dim u As Long
u = 12
For y = 12 To UBound(arr, 1)
If InStr(1, arr(y, 1), "итого", vbTextCompare) > 0 Then
If y >= u + 1 Then
.Range(.Cells(y, 7), .Cells(y, 11)).FormulaR1C1 = "=SUM(R[-" & y - u & "]C:R[-1]C)"
End If
u = y + 1
End If
Next
End With
End Sub
Sub ПроставитьМУСС()
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Dim y As Long
y = .Cells(.Rows.Count, 1).End(xlUp).Row
If y = 1 Then Exit Sub
Dim arr As Variant
arr = .Range(.Cells(1, 1), .Cells(y, 1))
Dim u As Long
u = UBound(arr, 1)
For y = UBound(arr, 1) To 1 Step -1
Select Case arr(y, 1)
Case 1
u = y + 1
Case "ИТОГО"
If y < u - 1 Then
.Cells(y, 2).Resize(1, 3).FormulaR1C1 = "=SUM(R[" & u - y & "]C:R[1]C)"
End If
u = y - 1
End Select
Next
End With
End Sub
с этим разобрался спасибо) а можно ли добавить условие чтобы он ставил формулу суммирования в строку содержащую итого, но суммировал только строки ниже содержащие слово договор? Мне кажется нужно формулу сумм заменить на суммесли в моем случае, но не могу ее записать макрос выдает ошибку
Sub DogWar()
Dim Application_Calculation As Long
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Dim y As Long
y = .Cells(.Rows.Count, 1).End(xlUp).Row
If y = 1 Then Exit Sub
Dim arr As Variant
arr = .Range(.Cells(1, 1), .Cells(y, 1))
Dim brr As Variant
For y = UBound(arr, 1) To 1 Step -1
Select Case arr(y, 1)
Case 1
Case "ИТОГО"
If Not IsEmpty(brr) Then
.Cells(y, 2).Resize(1, 3).FormulaR1C1 = "=" & Join(brr, "+")
Erase brr
brr = Empty
End If
Case Else
If LCase(arr(y, 1)) Like "*договор*" Then
If IsEmpty(brr) Then
ReDim brr(0 To 0)
Else
ReDim Preserve brr(0 To UBound(brr) + 1)
End If
brr(UBound(brr)) = "R" & y & "C"
End If
End Select
Next
.UsedRange.Calculate
End With
Application.Calculation = Application_Calculation
End Sub
Sub DogWar()
Dim Application_Calculation As Long
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Dim y As Long
y = .Cells(.Rows.Count, 1).End(xlUp).Row
If y = 1 Then Exit Sub
Dim arr As Variant
arr = .Range(.Cells(1, 1), .Cells(y, 1))
Dim brr As Variant
For y = UBound(arr, 1) To 1 Step -1
If LCase(arr(y, 1)) Like "* (кск-)*" Then
If Not IsEmpty(brr) Then
.Cells(y, 2).Resize(1, 3).FormulaR1C1 = "=" & Join(brr, "+")
Erase brr
brr = Empty
End If
Else
If LCase(arr(y, 1)) Like "*договор*" Then
If IsEmpty(brr) Then
ReDim brr(0 To 0)
Else
ReDim Preserve brr(0 To UBound(brr) + 1)
End If
brr(UBound(brr)) = "R" & y & "C"
End If
End If
Next
.UsedRange.Calculate
End With
Application.Calculation = Application_Calculation
End Sub
В аналогичном макросе заменил кск- и договор и макрос ругается на строку .Cells(y, 2).Resize(1, 3).FormulaR1C1 = "=" & Join(brr, "+") run-time error 1004 application-defined or object-defined error
Sub dogwar()
Dim Application_Calculation As Long
Application_Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
Set sh = ActiveSheet
With sh
Dim y As Long
y = .Cells(.Rows.Count, 1).End(xlUp).Row
If y = 1 Then Exit Sub
Dim arr As Variant
arr = .Range(.Cells(1, 1), .Cells(y, 1))
Dim brr As Variant
For y = UBound(arr, 1) To 1 Step -1
If instr(1, arr(y,1), "деятельность", vbtextcompare >0 then
If Not IsEmpty(brr) Then
.Cells(y, 2).Resize(1, 3).FormulaR1C1 = "=" & Join(brr, "+")
Erase brr
brr = Empty
End If
Else
If instr(1, arr(y,1), "ние ДС", vbtextcompare) > 0 Then
If IsEmpty(brr) Then
ReDim brr(0 To 0)
Else
ReDim Preserve brr(0 To UBound(brr) + 1)
End If
brr(UBound(brr)) = "R" & y & "C"
End If
End If
Next
.UsedRange.Calculate
Dim w As Long
W = .Cells(.Rows.Count, 1).End(xlUp).Row
If w = 1 Then Exit Sub
Dim azz As Variant
azz = .Range(.Cells(1, 1), .Cells(w, 1))
Dim bzz As Variant
For w = UBound(azz, 1) To 1 Step -1
If instr(1, azz(w,1), "ние ДС", vbtextcompare >0 then
If Not IsEmpty(bzz) Then
.Cells(w, 2).Resize(1, 3).FormulaR1C1 = "=" & Join(bzz, "+")
Erase bzz
bzz = Empty
End If
Else
If instr(1, azz(w,1), "КСК", vbtextcompare) > 0 Then
If IsEmpty(bzz) Then
ReDim bzz(0 To 0)
Else
ReDim Preserve bzz(0 To UBound(bzz) + 1)
End If
bzz(UBound(bzz)) = "R" & w & "C"
End If
End If
Next
.UsedRange.Calculate
Dim q As Long
Q = .Cells(.Rows.Count, 1).End(xlUp).Row
If q = 1 Then Exit Sub
Dim aqq As Variant
aqq = .Range(.Cells(1, 1), .Cells(q, 1))
Dim bqqAs Variant
For q = UBound(aqq, 1) To 1 Step -1
If instr(1, aqq(q,1), "Кск", vbtextcompare >0 then
If Not IsEmpty(bqq) Then
.Cells(q, 2).Resize(1, 3).FormulaR1C1 = "=" & Join(bqq, "+")
Erase bqq
bqq = Empty
End If
Else
If instr(1, aqq(q,1), "сцвд", vbtextcompare) > 0 Then
If IsEmpty(bqq) Then
ReDim bqq(0 To 0)
Else
ReDim Preserve bqq(0 To UBound(bqq) + 1)
End If
bqq(UBound(bqq)) = "R" & q & "C"
End If
End If
Next
.UsedRange.Calculate
End with
Application.Calculation = Application_Calculation
End Sub
Рабочий файл к сожалению не могу загрузить, а на файлах примера ошибку тоже не могу повторить, макрос срабатывает на обоих листах, но в рабочих файлах на втором листе не работает, но если скопирую лист в новую книгу, выйду из экселя и снова зайду в файл то макрос сработает, не могу понять в чем проблема с рабочими файлами(
Заметил что если в файле больше 1700 строк то макрос выдает ошибку, если меньше то срабатывает без проблем, то есть в рабочем файле удаляю строки и все хорошо