Copy every 5 Ranges And make it One On the Basis of First Column Unique Value

[Panki]

Dear All,

Below Code Copy Multiple Row Ranges and Make It one . It Is working Fine ,but the only problem is that, it takes lot of time when data is huge .


My Sheet Contain a

lmost (2600*5 Row ranges) and below code convert them into 2600 with Column "A"( Which is common Value)

But it takes around 20/30minutes. Please help me in reducing the time .


Public Sub MultipleRowsToOneRow_S6()

Dim lastRow As Long
Dim thisRow As Long
Dim lastCol As Long
Dim nextCol As Long

Application.ScreenUpdating = False
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
thisRow = 2
Do While thisRow <= lastRow
If Cells(thisRow, "A").Value = Cells(thisRow - 1, "A").Value Then
nextCol = Cells(thisRow - 1, Columns.Count).End(xlToLeft).Column + 1
lastCol = Cells(thisRow, Columns.Count).End(xlToLeft).Column
Range(Cells(thisRow, "B"), Cells(thisRow, lastCol)).Copy Destination:=Cells(thisRow - 1, nextCol)
Cells(thisRow, "A").EntireRow.Delete
lastRow = lastRow - 1
Else
thisRow = thisRow + 1
End If
Loop
Application.ScreenUpdating = True

End Sub

 

[Kaper]

If your data is as regular as shown on a screenshot (and as it seems from your code) a totaly diffterent approach could be used:

Public Sub MultipleRowsToOneRow_S6_Kaper()
Dim lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:E" & lastRow).Copy Range("F1")
Range("B3:E" & lastRow).Copy Range("J1")
Range("N1:N" & lastRow).Formula = "=mod(ROW()-1,3)"
ActiveSheet.Calculate
Range("N1:N" & lastRow).Value = Range("N1:N" & lastRow).Value
Range("A1:N" & lastRow).Sort key1:=Range("N1"), order1:=xlAscending, Header:=xlNo
Rows((lastRow / 3) + 1 & ":" & lastRow).Delete shift:=xlUp
Columns("N:N").Delete shift:=xlToLeft
End Sub

I don't think you will need ScreenUpdating etc, as this code shall do 2600 rows in no time

Short explanation
First: 2 copies of columns B:E are made next to original data, but each copy is shifted a row up.
if you would look on data at this stage rows 1; 4; 7; ... are ready for you but there are rows 2;3;5;6;8;9; ... which shall be deleted

Then the formula is inserted in N - it generates series 0 1 2 0 1 2 0 1 2 ... in N1:N....
Then formula results are converted into values (as copy and paste special as values)

Then the whole table is sorted and only upper 1/3 of rows is left, the bottom 2/3 are deleted

Sorting was used, because deleting rows one by one would be time consuming step. Even filtereing the data with 1 or 2 in column N and deleting wisible rows would take longer than deleting one contignous region.

 

[Panki]

Okey.. I Will try your code.. Only few concerns
Query 1= row would be 5 instead 3
Query 2- I want columns range should be copied dynamically, because range could verry as per data.