View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
Claus Busch Claus Busch is offline
external usenet poster
 
Posts: 3,872
Default Rollup/combine data from several below rows into the TopRow based on keys

Hi Johan,

Am Sat, 20 Jul 2019 01:03:44 -0700 (PDT) schrieb JS SL:

I've got a sheet with column A till CH
The sheet has several duplicates in rows because in the columns M - BJ and BP - CH there is data showed in one of the columns but in a separated row.

For example

Column M N O P
Row1 a
Row2 b
Row3 c
Row4 d

That should be

Column M N O P
Row1 a b c d

But,.... there are also rows that don't need to combine.
For make the difference in yes/no to combine and till what row I made some codes in column A. In column B is a key registered which reflects a combined created unique value to show which rows belong to each other.

Column A B
Row1 M Key
Row2 F Key
Row3 F Key
Row4 B Key
Row5 U Key
Row6 B Key
Row7 B Key
Row8 B Key
Row9 M Key
Row10 F Key
Row11 F Key
Row12 F Key
Row13 B Key


It should combine in the row with code M all the values registered in the the row with M itself and then together with the values in the below rows where F is the code in column A and in column B the key is the same.

So in row 1 you get the registered data from row1 & row2 & row3
in row9 you get the registered data from row9 & row10 & row11 & row12

This should be done only for columns M till BJ, and BP till CH.


try:

Sub Test()
Dim LRow As Long, i As Long, Last As Long
Dim c As Range, myRng1 As Range, myRng2 As Range
Dim FirstAddr As String

With ActiveSheet
LRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set c = .Range("A:A").Find("M", LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddr = c.Address
Do
For i = c.Row + 1 To LRow
If .Cells(i, "A") = "F" And .Cells(i, "B") = .Cells(i - 1, "B") Then
Else
Last = i - 1
Exit For
End If
Next
Set myRng1 = .Range(.Cells(c.Row, "M"), .Cells(Last, "BJ"))
Set myRng2 = .Range(.Cells(c.Row, "BP"), .Cells(Last, "CH"))
.Cells(c.Row, "M") = Application.TextJoin("", 1, myRng1)
.Cells(c.Row, "BP") = Application.TextJoin("", 1, myRng2)
Set c = .Range("A:A").FindNext(c)
Loop While Not c Is Nothing And c.Address < FirstAddr
End If
End With
End Sub


Regards
Claus B.
--
Windows10
Office 2016