Объединить ячейки в зависимости от значения в столбце для диапазона ячеек

Question

Мне нужно добавить данные в строку G и слить дату в строке A, если строка E имеет одинаковые строки. Я нашел Excel VBA - Combine rows with duplicate values in one cell and merge values in other cell, что очень полезно, но мне нужно сделать это для диапазона G7: G65536, потому что мои строки от 1 до 6 объединены.

Есть ли способ, которым я могу адаптировать этот код?

Я пытался поиграть с ним, но это не дало мне никаких результатов.

Answer 1

Я использовал ваши комментарии для получения следующих данных образца.

Я подозреваю, что идея состоит в том, чтобы использовать столбец E в качестве единственного ключевого столбца и заполнителя (ака SUM) величины из столбца G при построении каскадного списка дат из столбца A. Первые 6 строк Worksheet.UsedRange property следует игнорировать, поскольку в первых шести строках есть по крайней мере Range.MergeCells property с соединенными Areas property. TBH, я обнаружил, что ваш оригинальный рассказ противоречил вашим последним комментариям, поэтому я использовал последнее как «открытие».

Sub merge_some_row_data() 
    Dim rw As Long, lr As Long, s As Long, str As String 

    Application.ScreenUpdating = False 
    With ActiveSheet.Cells(1, 1).CurrentRegion 
     With .Cells(7, 1).Resize(.Rows.Count - 6, .Columns.Count) 
      .Cells.Sort Key1:=.Columns(5), Order1:=xlAscending, _ 
         Key2:=.Columns(1), Order2:=xlAscending, _ 
         Orientation:=xlTopToBottom, Header:=xlNo 
     End With 
     lr = .Rows.Count 
     For rw = .Rows.Count To 7 Step -1 
      If .Cells(rw, "E").Value2 <> .Cells(rw - 1, "E").Value2 And rw < lr Then 
       .Cells(rw, "G") = Application.Sum(.Range(.Cells(rw, "G"), .Cells(lr, "G"))) 
       str = vbNullString 
       For s = rw To lr 
        str = str & Chr(59) & .Cells(s, "A").Text 'Chr(59) is the ASCII code for a semi-colon 
       Next s 
       .Cells(rw, "A") = Mid(str, 2) 'truncate off the firsty semi-colon 
       .Cells(rw + 1, 1).Resize(lr - rw, 1).EntireRow.Delete 
       lr = rw - 1 
      End If 
     Next rw 
    End With 
    Application.ScreenUpdating = True 
End Sub 

После запуска кода результаты выглядят следующим образом.

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