For several rows: Copying all cells in a row until blank

[vmc62]

First of all, I want to thank the people that has helped me with their codes.

I posted before with a problem, that despite the codes received I still can't find solution.

I was looking for someone that could help me with a code that does this to my excel data:

From:
RA | 21 | 32 | 21 | (blank)|
RA | 12 | 23 | 45 | (blank)|
EN | 18 | 15 | 20 | (blank)|
EN | 23 | 34 | 21 | (blank)|
HS | 14 | 15 | 16 | (blank)|
HS | 13 | 12 | 11 | (blank)|


To:
RA | 21 | 32 | 21 | EN | 18 | 15 | 20 |
RA | 12 | 23 | 45 | EN | 23 | 34 | 21 |
HS | 14 | 15 | 16 |
HS | 13 | 12 | 11 |

End then To:

RA | 21 | 32 | 21 | EN | 18 | 15 | 20 | HS | 14 | 15 | 16 |
RA | 12 | 23 | 45 | EN | 23 | 34 | 21 | HS | 13 | 12 | 11 |

Someone has given me this code (which I thank him for it)

Sub Test()
    Dim Sh As Worksheet
    Dim Col As Long
    Dim RowFrom As Long
    Dim RowTo As Long
    Set Sh = Worksheets("Sheet1")
    Col = Sh.Cells(1, Sh.Columns.Count).End(xlToLeft).Column + 1
    RowFrom = 1
    RowTo = 1
    With Sh
        Do
            If IsEmpty(.Cells(RowFrom, 1)) Then Exit Sub
            If .Cells(RowFrom, 1).Value = "EN" Then
                With .Range(.Cells(RowFrom, 1), .Cells(RowFrom, Col - 1))
                    .Copy Sh.Cells(RowTo, Col)
                    .Delete Shift:=xlUp
                    RowTo = RowTo + 1
                End With
            Else
                RowFrom = RowFrom + 1
            End If
        Loop
    End With
End Sub

Which solves my problem when there is not so much data (I think).

But my excel sheet has thousands of entries, so when I run it in my excel sheet, the program starts running indefinitely and it seems it will never stop.

So this time I'm attaching part of my excel sheet (with only hundreds cells of data). In this case the code works, but its output it's not what I need exactly, and again, I need it to work for thounsands of entries.

If someone can assist me, check my file attached, and help me with this issue I thank you all in advance.


Regards,

Victor

[davesexcel]

Hi,
This may work for you,
I have added a top row to your data sheet
in the Filtered sheet There are the three Items to Filter for
Run the filter macro to see what happens,
here's the code

Sub Filter()
    Dim rng As Range
    Dim rng2 As Range
    Dim R As Range
    Dim C As Range
    Dim sh As Worksheet
    Set sh = Worksheets("Filtered")
    Set R = sh.Range("A1", sh.Range("A65536").End(xlUp))

    Worksheets("Filtered").Range("B1:IV65536").ClearContents
    For Each C In R.Cells

        With Worksheets("Raw data 2")
            .Range("A1").AutoFilter Field:=1, Criteria1:=C
        End With

        With Worksheets("Raw data 2").AutoFilter.Range
            On Error Resume Next
            Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                       .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With
        If rng2 Is Nothing Then
            MsgBox "No data to copy"
        Else
            Set rng = Worksheets("Raw data 2").AutoFilter.Range
            rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _
                    Destination:=Worksheets("Filtered").Range("IV1").End(xlToLeft).Offset(0, 1).Range("A1")

        End If

        Worksheets("Raw data 2").AutoFilterMode = False
    Next C
            Worksheets("Raw data 2").AutoFilterMode = False

End Sub

The copy macro is modified from :
http://www.contextures.com/xlautofilter03.html#Copy
Hopefully it doesn't cut any data off ....


I am 4 KB over the limit so here is a link to your example..
http://cid-a46da3272307a404.skydrive...sposeMacro.xls