Grouping data by rows in vba

lucky245

New Member
Joined
Jun 21, 2010
Messages
7
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
 
Last edited:

Some videos you may like

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this for results on sheet2.
Code:
[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

New Member
Joined
Jun 21, 2010
Messages
7
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,258
Messages
5,600,568
Members
414,389
Latest member
MarkElla

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top