Merging data and deleting empty rows

[Detectiveclem]

Can anyone assist please? I have a spreadsheet with data acrosscolumns A-G, However quite frequently the data in column C is spread over oneor two cells on the rows below. When this spread of data occurs, those adjacentcells in column A & B to the left and D-G on the right are always blank.

I want to be able to combine the data from the cells with nodata adjacent to into the cell above them.

Any help apprieciate

 

[Yongle]

Hi
Test in a copy of your workbook

Run from the sheet containing rows to be combined

[COLOR=#006400]Sub CombinrRows()[/COLOR]
Dim Wf, r As Long, MyStr As String, Rng As Range, A_G As Range, Cel As Range
Set Wf = WorksheetFunction
GoFaster True
   Set Cel = Range("C:C").Find("*", searchdirection:=xlPrevious)
        Do
            Set A_G = Cells(Cel.Row, 1).Resize(, 7)
            If Wf.CountA(A_G) = Wf.CountA(Cel) Then
                If Len(MyStr) = 0 Then MyStr = Cel Else MyStr = Cel & " " & MyStr
                Cel.ClearContents
                If Rng Is Nothing Then Set Rng = Cel Else Set Rng = Union(Cel, Rng)
                    If Wf.CountA(A_G.Offset(-1)) <> Wf.CountA(Cel.Offset(-1)) Then
                        Set Cel = Cel.Offset(-1)
                        Cel = Cel & " " & MyStr
                        MyStr = ""
                    End If
            End If
            Set Cel = Cel.Offset(-1)
        Loop Until Cel.Row = 1
    If Not Rng Is Nothing Then Rng.EntireRow.Delete
GoFaster False
[COLOR=#006400]End Sub[/COLOR]

[COLOR=#006400]Private Sub GoFaster(TrueFalse As Boolean)[/COLOR]
    With Application
        .ScreenUpdating = Not TrueFalse
        .Calculation = xlCalculationManual
        If TrueFalse = True Then Else .Calculation = xlCalculationAutomatic
    End With
[COLOR=#006400]End Sub[/COLOR]

 

[Detectiveclem]

Dear Yongle,

Sorry for the delay in relying. When I first ran this, I received the response that Excel was not working which presumably was caused by the amount of data I wasasking to be changed. I then broke this down to about 10,000 rows and then yourmacro worked perfectly. I simply repeated the process in 10,000 row batchesuntil I had done them all.



Everything worked perfectly, I am really impressed as youhave saved me days if not weeks of work.


I doubt I would ever be able to right a complex macro likethis, it is well beyond my capabilities. You are a genius in my eyes, so onceagain thank you very much.


Kind regards, Paul

 

[Yongle]

thanks for the feedback

I received the response that Excel was not working which presumably was caused by the amount of data I was asking to be changed. I then broke this down to about 10,000 rows and then yourmacro worked perfectly. I simply repeated the process in 10,000 row batches until I had done them all.

Something you could try immediately woud be to remove this line (unnecessary because the row is being deleted later in the procedure)

Cel.ClearContents

If you check back in a few days I will post amended code that should run quicker

 

[Yongle]

Interacting with the worksheet is slow - but it is a much easier to follow what is going on!

This code does the same thing as previous code but
- assigns the values (in one hit) into an array
- checks and updates array values in memory
- assigns updated array values to sheet (in one hit)
- deletes rows where column C values integrated into cell above

[COLOR=#006400]Sub CombinrRows()
[/COLOR]Dim r As Long, r1 As Long, MyStr As String, Rng As Range, Cel As Range
Dim DataTbl As Range, Arr As Variant, Str_r As String, Str_r1 As String

   Set Cel = Range("C:C").Find("*", searchdirection:=xlPrevious)
   Set DataTbl = Range("A1", Cel).Resize(, 7)
   Arr = DataTbl [COLOR=#008080][I]'assign values to array[/I][/COLOR]
        For r = UBound(Arr) To 2 Step -1
            r1 = r - 1
            Str_r = Arr(r, 1) & Arr(r, 2) & Arr(r, 4) & Arr(r, 5) & Arr(r, 6) & Arr(r, 7)
            Str_r1 = Arr(r1, 1) & Arr(r1, 2) & Arr(r1, 4) & Arr(r1, 5) & Arr(r1, 6) & Arr(r1, 7)
            If Len(Str_r) = 0 Then
                If Len(MyStr) = 0 Then MyStr = Arr(r, 3) Else MyStr = Arr(r, 3) & " " & MyStr
                Arr(r, 3) = ""
                If Rng Is Nothing Then Set Rng = Cells(r, 3) Else Set Rng = Union(Cells(r, 3), Rng)
                    If Len(Str_r1) > 0 Then
                        Arr(r1, 3) = Arr(r1, 3) & " " & MyStr
                        MyStr = ""
                    End If
            End If
        Next
GoFaster True
    DataTbl = Arr   [COLOR=#008080][I]'assign updated values to sheet[/I][/COLOR]
    If Not Rng Is Nothing Then Rng.EntireRow.Delete
GoFaster False
[COLOR=#006400]End Sub[/COLOR]

[COLOR=#006400]Private Sub GoFaster(TrueFalse As Boolean)[/COLOR]
    With Application
        .ScreenUpdating = Not TrueFalse
        .Calculation = xlCalculationManual
        If TrueFalse = True Then Else .Calculation = xlCalculationAutomatic
    End With
[COLOR=#006400]End Sub[/COLOR]

 

[Detectiveclem]

Thank you Yongle, I really appreciate your help.

Regarding the above two codes, do I use both?

Thanks again, Paul

 

[Yongle]

Regarding the above two codes, do I use both?

Delete all previous code and use post#5 procedures only

 

[Detectiveclem]

Thank you Yongle, you are a star.

 

[Yongle]

thanks for the feedback