VBA to copy highlighted cells to specific worksheet based on text in another cell

[pete4monc]

I wonder if anyone can help with the below, please.
I'm trying to write a macro that will run from a button that looks along a specific row based on the selected cell "A2", finds the text "y" in a cell along that row, in the first column. Then copies cells A2,B2,C2,D2,E2 from this worksheet into another worksheet with the same name as the column heading on sheet1, that had the text "y". Then loops to find all the remaining "y" texts in the remaining columns?

example: highlighted cell is A2. vba looks along line 2, locates the first "y". The column is headed "sales". It then copies cells A2,B2,C2,D2,E2 and pastes the data into the next available line in worksheet "sales". It then looks for the next "y" in the next column ie: headed "Purchasing" on row 2 and copies the same cells (A2,B2,C2,D2,E2) to the worksheet called "Purchasing", and so on until there are no more "y" texts.

As you can see in the code I have got something to work but it copies the whole row and I can not get it to loop to the next column on that row.

I hope the above makes sense to you boffins?
Thanks Pete

PS: I'm new to vba so go easy on me ...lol

 

[mumps]

Do you want to do that only for the selected row or for all the rows?

 

[pete4monc]

@mumps Hi , only for that row.

 

[mumps]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim lCol As Long, sAddr As String, fnd As Range, x As Long, ws As Worksheet
    lCol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
    x = ActiveCell.Row
    Set fnd = Rows(x).Find("y", LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        sAddr = fnd.Address
        Do
            Set ws = Sheets(Cells(4, fnd.Column).Value)
            With ws
                Range("A" & x & ":E" & x).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
            End With
            Set fnd = Rows(x).FindNext(fnd)
        Loop While fnd.Address <> sAddr
        sAddr = ""
    End If
    Application.ScreenUpdating = True
End Sub

 

[pete4monc]

@ mumps Absolutely brilliant!! Thanks.
I'm new to vba and I have being butchering some vba on and off for days now and you go and do it in less then an hour. I have got some extra bits like messages and the sort to do, but hopefully I can sort out the smaller bits.
Thanks for you quick response and help.

 

[mumps]

You are very welcome.