Grouping data by rows in vba

[lucky245]

I have a spreadsheet with over 6000 rows the size of which is dynamic. This is probably so simple but I cant work it out without every other time getting myself in a continuous loop. Excuse my poor coding but I do at least try

The first few columns of each row may be identical but the remaining 5 in this example will always be unique. If the first four columns are identical I am trying to get one row with all the information in it. Case differences are required as they mean different things.

Date	Com	Code	Class	AC	BC	CC	DA	EA
10/11/2016	EN	A6461	KP	i
10/11/2016	EN	A6461	KP		R
10/11/2016	EN	A6461	KP			r
10/11/2016	EN	A6461	KP				S
10/11/2016	EN	A6461	KP					s
12/12/2017	KP	A4567	EC	R
12/12/2017	KP	A4567	EC		s
12/12/2017	KP	A2345	EC				S

<tbody>
</tbody>

Result being

Date	Com	Code	Class	AC	BC	CC	DA	EA
10/11/2016	EN	A6461	KP	i	R	r	S	s
12/12/2017	KP	A4567	EC	R	s
12/12/2017	KP	A2345	EC				S

<tbody>
</tbody>

Sub mergeinfo()
Dim i, y, j As Integer
Dim Rowcount As Long
cgws.Select ‘worksheet name
Rowcount = cgws.UsedRange.Rows.Count
For i = 2 To Rowcount

If i < Rowcount Then ' I added this as it seems to get caught in a loop otherwise
If Cells(i, 3) = Cells(i + 1, 3) Then

Rowcount = cgws.UsedRange.Rows.Count
For y = 4 To cgws.UsedRange.Columns.Count
If Cells(i + 1, y) <> "" Then 'if the cell isn’t empty then
Cells(i, y) = Cells(i + 1, y) ' make the first row add value of next row full cell to itself
Cells(i + 1, 4).EntireRow.Delete 'delete the second row
Rowcount = cgws.UsedRange.Rows.Count 're-evaluate size of table
Exit For
End If
Next y


i = i – 1 'stops I from incrementing until no more identical rows
End If
Else
Exit Sub ' exit sub if i isn’t smaller than rowcount
End If
Next i

End Sub

 

[MickG]

Try this for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG04Jan32
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Ray = ActiveSheet.Cells(1).Range("A1").CurrentRegion
    ReDim nRay(1 To UBound(Ray, 1), 1 To UBound(Ray, 2))
        [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
    
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
        [COLOR="Navy"]If[/COLOR] Not .Exists(Ray(n, 3)) [COLOR="Navy"]Then[/COLOR]
            c = c + 1
                [COLOR="Navy"]For[/COLOR] Ac = 1 To UBound(Ray, 2)
                    [COLOR="Navy"]If[/COLOR] Ray(n, Ac) <> "" [COLOR="Navy"]Then[/COLOR] nRay(c, Ac) = Ray(n, Ac)
                [COLOR="Navy"]Next[/COLOR] Ac
            .Add Ray(n, 3), c
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]For[/COLOR] Ac = 5 To UBound(Ray, 2)
                 [COLOR="Navy"]If[/COLOR] Ray(n, Ac) <> "" [COLOR="Navy"]Then[/COLOR] nRay(.Item(Ray(n, 3)), Ac) = Ray(n, Ac)
            [COLOR="Navy"]Next[/COLOR] Ac
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, UBound(Ray, 2))
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[lucky245]

I have tried this and with a slight adjustment on the variables to fit my actual data set at first look it works like a dream thank you. No mass loops.

 

[MickG]

You're welcome