Страницы: 1
RSS
Проставить =СУММ() в строки, содержащие ИТОГО
 
Добрый день.
Подскажите, пожалуйста, как можно решить подобную задачу...

Во вложении файлик. Там две таблички для примера: Источник и Обработанный.
Нужно чтобы табличка Источник после обработки стала как табличка Обработанный, а именно - по первому столбцу, если там написано "Итого", то в остальных столбцах должна вставиться формула суммы значений выше (до предыдущей строчки с "Итого"). Т.е. там, где красные цыфры должны быть формулы суммы (первоначально в Источнике стоят значения). Естественно, размерность таблицы может менятся по стокам (разный набор данных), но по столбцам формат не меняется.
Хотелось бы записать макрос, т.к. с подобными выгрузками приходиться работать довольно часто.

Подскажите, если кто сталкивался с подобным.
Спасибо!
Изменено: vikttur - 22.06.2021 19:15:59
 
Код
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 (Добавил название темы после сообщения от Джека Известного.)
 
Alexander, МатросНаЗебре, прекрасное название темы, господа  :D
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
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
Изменено: New - 15.06.2021 20:03:58
 
New, МатросНаЗебре, ребята, спасибо большое!
Изменено: Alexander - 17.06.2021 18:53:41
 
Alexander, а Jack Famous тут при чём? Если основной код написал МатросНаЗебре? )
 
Подскажите а как сделать тоже самое но суммировать строки ниже содержащие слово договор?
Изменено: Александр Брусницын - 16.06.2021 16:08:26
 
Код
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

Цитата
Александр Брусницын написал:
XlUp заменил на xlDown но не помогло
Это сильно )
 
с этим разобрался спасибо) а можно ли добавить условие чтобы он ставил формулу суммирования в строку содержащую итого, но суммировал только строки ниже содержащие слово договор?
Мне кажется нужно формулу сумм заменить на суммесли в моем случае, но не могу ее записать макрос выдает ошибку
Изменено: vikttur - 22.06.2021 19:17:15
 
Цитата
Александр Брусницын написал:
нужно формулу сумм заменить на суммесли
СУММ быстрее, чем СУММЕСЛИ
 
Код
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
 
МатросНаЗебре,не получается адаптировать под свою таблицу, модно ли сделать на конкретном примере? Вместо "итого" только суммировать по "кск-"
Пример
Изменено: Александр Брусницын - 17.06.2021 16:27:31
 
Ссыль у меня не открывается.  
 
выложил файл, с телефона не мог добавить.
Изменено: Alex.gbk - 17.06.2021 18:05:37 (файл)
 
Код
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
 
Снова ждём с нетерпеньем пример.
 
Макрос выполняется на 1 листе книги, на втором листе выдает ошибку на строку
Код
Cells(w,  2).Resize(1, 3).FormulaR1C1 = "=" & Join(bzz, "+")
, таблица аналогична файлу из примера
Код
 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
Изменено: vikttur - 22.06.2021 19:18:37
 
Цитата
Alex.gbk написал:
таблица аналогична файлу из примера
Не удалось повторить ошибку. Нужен пример.
 
Рабочий файл к сожалению не могу загрузить, а на файлах примера ошибку тоже не могу повторить, макрос срабатывает на обоих листах, но в рабочих файлах на втором листе не работает, но если скопирую лист в новую книгу, выйду из экселя и снова зайду в файл то макрос сработает, не могу понять в чем проблема с рабочими файлами(
 
Alex.gbk, Проверьте рабочий файл на наличие ошибок #НД, #ДЕЛО/0 и т.п.
 
msi2102, в рабочем файле при выгрузке отсутствуют формулы ошибок нет
 
Заметил что если в файле больше 1700 строк то макрос выдает ошибку, если меньше то срабатывает без проблем, то есть в рабочем файле удаляю строки и все хорошо
Страницы: 1
Наверх