Compress four rows into one row

[tx7399]

Hi everyone,

I have a worksheet of 85K+ plus rows and 20 columns.
Col A contains the OrgName which could be listed up to five times in the sheet. After sorting by OrgName the successive rows each contain some of the info about the Organization. Is there a way to 'compress' the four or five rows into one row and thereby have a complete record on just the one row? The other rows should then be deleted. I have attached a sample worksheet (the actual worksheet extends out 20 columns to Col T and is 85K rows).

Thanks

20236

[Paul_Hossler]

Try this





Option Explicit
Sub CompressRows()
Dim datRange As Range
Dim rowNum As Long, colNum As Long

Application.ScreenUpdating = False

Set datRange = ActiveSheet.Cells(1, 1).CurrentRegion

With datRange
For rowNum = .Rows.Count To 3 Step -1
If .Cells(rowNum, 1).Value = .Cells(rowNum - 1, 1).Value Then
For colNum = 1 To .Columns.Count
'if cell above is empty, and this cell is not blank
If Len(.Cells(rowNum - 1, colNum).Value) = 0 And Len(.Cells(rowNum, colNum).Value) > 0 Then
'make the cell above = this cell
.Cells(rowNum - 1, colNum).Value = .Cells(rowNum, colNum).Value
End If
Next colNum

.Rows(rowNum).Delete
End If
Next rowNum
End With
Application.ScreenUpdating = True
End Sub

[tx7399]

Thanks for the quick response. Indeed the code processed the sample data flawlessly, however, when I ran the code in the full worksheet it seems to have bogged down. It has been running for the last 20+ minutes and is still running with no errors. Do I need to let it run? or is there a way to speed it up? Thanks again.

[tx7399]

Thanks, Paul_Hossler !!
It processed for about an hour and compressed 85523 rows to 32877 rows.
I just need to correct the slight differenc in the waay accounts are named
(Ex: ABC CO vs ABC CO INC) to get down to the 22740 actually unique accounts.

Thanks very much! Nice solution.

[mdmackillop]

A different method to try EDIT: Tested on a bigger sample. Stick with Paul's; its much quicker.

Option Explicit
Option Base 1
Sub Test()
Dim Data, arr()
Dim dic, c
Dim wsO As Worksheet, sh As Worksheet
Dim i&, j&
Dim r As Range, Rng As Range
Dim a As Range, b As Range

Set wsO = Sheet1
Set r = wsO.Columns(1).Cells
Set dic = CreateObject("Scripting.dictionary")
Data = wsO.Cells(1, 1).CurrentRegion
ReDim arr(UBound(Data), 14)
For i = 2 To UBound(arr)
If Not dic.exists(Data(i, 1)) Then dic.Add Data(i, 1), vbNullString
Next i
On Error Resume Next
For Each c In dic.keys
j = j + 1
Set a = r.Find(c, r(1), , , , 1)
Set b = r.Find(c, r(1), , , , 2)
Set Rng = Range(a, b)
For i = 1 To 14
arr(j, i) = Rng.Offset(, i - 1).Find("*")
Next i
Next c
On Error GoTo 0
Set sh = Worksheets.Add
sh.Cells(2, 1).Resize(UBound(Data), 14) = arr
End Sub

[Paul_Hossler]

Sorry - I should have thought about that

Add the two pieces below and see




Option Explicit
Sub CompressRows()
Dim datRange As Range
Dim rowNum As Long, colNum As Long

Application.ScreenUpdating = False

Set datRange = ActiveSheet.Cells(1, 1).CurrentRegion

With datRange
For rowNum = .Rows.Count To 3 Step -1
'add
If rowNum Mod 100 = 0 Then
Application.StatusBar = "Processing Row " & Format(rowNum, "#,##0")
DoEvents
End If

If .Cells(rowNum, 1).Value = .Cells(rowNum - 1, 1).Value Then
For colNum = 1 To .Columns.Count
'if cell above is empty, and this cell is not blank
If Len(.Cells(rowNum - 1, colNum).Value) = 0 And Len(.Cells(rowNum, colNum).Value) > 0 Then
'make the cell above = this cell
.Cells(rowNum - 1, colNum).Value = .Cells(rowNum, colNum).Value
End If
Next colNum

.Rows(rowNum).Delete
End If
Next rowNum
End With
'add
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

[mdmackillop]

Another attempt. About 2 secs for 85000 rows


Option Explicit
Option Base 1


Sub Test()
Dim Data, arr(), x
Dim dic, c
Dim wsO As Worksheet, sh As Worksheet
Dim i&, j&, k&
Dim r As Range, Rng As Range
Dim a&

Set wsO = Sheet1
Set r = wsO.Columns(1).Cells
Set dic = CreateObject("Scripting.dictionary")
Data = wsO.Cells(1, 1).CurrentRegion
ReDim arr(UBound(Data), 14)
For i = 2 To UBound(arr)
If Not dic.exists(Data(i, 1)) Then
dic.Add Data(i, 1), i
Else
dic(Data(i, 1)) = dic(Data(i, 1)) & "," & i
End If
Next i
On Error Resume Next
For Each c In dic.keys
a = a + 1
x = Split(dic(c), ",")
For j = 1 To 14
For k = x(LBound(x)) To x(UBound(x))
If Data(k, j) <> "" Then
arr(a, j) = Data(k, j)
Exit For
End If
Next k
Next j
Next c
On Error GoTo 0
Set sh = Worksheets.Add
sh.Cells(2, 1).Resize(UBound(Data), 14) = arr
End Sub

[tx7399]

Awesome!! mdmackillop.
Thanks! The whole file processes in just seconds.

[snb]

or

Sub M_snb()
On Error Resume Next
sn = Sheet1.Cells(1).CurrentRegion
ReDim sp(1 To UBound(sn), 1 To UBound(sn, 2))

For j = 1 To UBound(sn)
If sn(j, 1) <> sn(j - 1, 1) Then y = y + 1

For jj = 1 To UBound(sn, 2)
If sn(j, jj) <> "" Then sp(y, jj) = sn(j, jj)
Next
Next

Sheet1.Cells(1).CurrentRegion = sp
End Sub