Суммирование ячеек в повторящихся строках

[baltimor]

Здравствуйте! Помогите пожалуйста. Нужно сравнить строки по столбцам C и D, и если есть одинаковые строки то значения этих строк из столбца F просуммировать и вывести сумму в объединенную ячейку в столбец I. Повторяющиеся строки выделить цветом. Для не повторяющихся строк просто вывести значения из столбца F в I. Файл примера прилагаю)

[sboy]

Добрый день.
Попробуйте использовать сводную таблицу

[baltimor]

К сожалению, нужен макрос

[Дмитрий Щербаков(The_Prist)]

К сожалению, об этом Вы забыли сказать сразу. Плюс Вы явно ничего не сделали сами для написания этого макроса. Поэтому придется ждать того, кому не лень будет решать за Вас Вашу задачу с нуля.

[baltimor]

Пока смог только это. Было стыдно такое выкладывать

Код (vb) Выделить Развернуть


Sub makros()
Dim k As Single


d = Sheets(1).Cells(Sheets(1).Cells.Rows.Count, 1).End(xlUp).Row

k = 0

For i = 3 To d Step 1

   If Sheets(1).Cells(i, 3) = Sheets(1).Cells(i + 1, 3) And Sheets(1).Cells(i, 4) = Sheets(1).Cells(i + 1, 4) Then

       k = k + CSng(Sheets(1).Cells(i, 6))
       Sheets(1).Cells(i, 9) = k
   Else
       Sheets(1).Cells(i, 9) = Sheets(1).Cells(i, 6)
       
   End If
Next i
End Sub


[sboy]

Было стыдно такое выкладывать

Почему? Вы честно пытаетесь, а  это приветствуется)
Немного Вас подправил в коде

Код (vb) Выделить Развернуть

Sub makros()
Dim k As Single
Sheets(1).Activate
 
d = Cells(Rows.Count, 1).End(xlUp).Row
 
k = 0
For i = 3 To d
 
  If Cells(i, 3) = Cells(i + 1, 3) And Cells(i, 4) = Cells(i + 1, 4) Then
  k = k + CSng(Cells(i, 6))
  End If
 
  If Cells(i, 3) <> Cells(i + 1, 3) And k = 0 Then
  Cells(i, 9) = Cells(i, 6)
  End If
  If Cells(i, 3) <> Cells(i + 1, 3) And k > 0 Then
    Cells(i, 9).Value = k + CSng(Cells(i, 6))
    k = 0
    End If
Next i
End Sub


[baltimor]

Немного Вас подправил в коде

Спасибо большое) подскажите еще пожалуйста как цветом выделить одинаковые строки и объединить ячейки.

[Дмитрий Щербаков(The_Prist)]

как цветом выделить одинаковые строки и объединить ячейки

Не помешает ознакомиться с правилами форума. Там есть и такой пункт:

4.16. Запрещено обсуждение, не связанных между собой вопросов в одной теме, например так: «Не получается установить заливку ячейки и еще почему-то у меня не обновляются темы». Первый вопрос следует обсуждать в разделе "Вопросы по Excel и VBA", а второй в разделе "Вопросы по работе форума". Так же не являются связанными темы "поиск последней ячейки" и "копирование выбранных ячеек", хоть и должны быть созданы в одном разделе.

[baltimor]

Не помешает ознакомиться с правилами форума. Там есть и такой пункт:

Так это же продолжение первого поста. Суммировать  повторяющиеся строки и выделить их цветом, объединив ячейки. Разве нет?

[vikttur]

Тема о суммировании. То, что в Вашей задаче и другие вопросы, не причина для размещения разных вопросов в одной теме.

[baltimor]

Понял, спасибо)

[sv2015]

добрый вечер,baltimor,не нашел как Вам надо,вариант макроса для #1 со считыванием в массив,кнопки use и повтор


   

Код (vb) Выделить Развернуть

Sub use()
    Dim z, k&, j&, t$ :  z = Range("A1:I" & Range("A" & Rows.Count).End(xlUp).Row).Value
    With CreateObject("scripting.dictionary"): .CompareMode = 1
        For k = 1 To UBound(z): t = z(k, 3) & z(k, 4)
         If .exists(t) = False Then
         m = m + 1: .Item(t) = m: For j = 1 To UBound(z, 2): z(m, j) = z(k, j): Next
         Else
           z(.Item(t), 6) = z(.Item(t), 6) + z(k, 6)
         End If
   Next
   For k = 3 To UBound(z): z(k, UBound(z, 2)) = z(k, 6): Next
   Range("A1:H" &  UBound(z)).ClearContents
   Range("A1").Resize(.Count, UBound(z, 2)).Value = z
End With
End Sub

[sv2015]

baltimor,добавил макрос для выделения цветом повторов


 

Код (vb) Выделить Развернуть

Sub цвет()
   Dim z, i&, j&
   z = Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row).Value
With CreateObject("scripting.dictionary")
  For i = 3 To UBound(z)
     .Item(z(i, 1)) = .Item(z(i, 1)) + 1
   Next
   For i = 3 To UBound(z)
     If .Item(z(i, 1)) > 1 Then Rows(i & ":" & i).Font.Color = -16776961
   Next
End With
End Sub

[vikttur]

sv2015, у Вас со зрением все в порядке? Замечания администратора и модератора не видели? Будете поддерживать беспорядок?

[baltimor]

добрый вечер,baltimor,не нашел как Вам надо,вариант макроса для #1 со считыванием в массив,кнопки use и повтор

Добрый день, прошу прощения только сейчас увидел ваш ответ. Спасибо) Подскажите пожалуйста как добавить еще столбец R для сравнения. Чтобы сравнивались строки по трем столбцам C, D, R.
При добавлении его в строку

Код (vb) Выделить Развернуть

For k = 1 To UBound(z): t = z(k, 3) & z(k, 4) все идет наперекосяк.