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.
<tbody>
</tbody>
Result being
<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
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: