Basic offset and 'skip blanks'

Hello, I am still very much learning VBA after the course, so the methods I am using may not be the most logical but hopefully your be able to help me solve a couple of issues I am having.

I have a block of data, which is always 18 columns in width but a varying amount of rows. This data is imported from a CSV file and I am trying to re-organise the data. The header of the 18 columns is initilas (3 letters). The rows beneath are either a "1" or a "0". I am using the formula =

If(Q4=1,Q$3,"")

Using VBA I am trying to copy this formula to the 18 colums and to however many rows there are; this could be 40-80 but varying each time.

My code, below so far, is probably a little confused as I have been trying to work this out for a couple of hours...

Sub NextCopyDataOver()

    'From now on it is reorganise of initials

    

    Dim CountR As Integer

    

    CountR = 0

    

    Sheets("organise").Select

    Range("AK4").Select

    ActiveCell.FormulaR1C1 = "=IF(RC[-20]=1,R3C[-20],"""")"

    Selection.Copy

    

    ActiveCell.Offset(1, 0).Select

    

    

    Do Until ActiveCell.Offset(1, -3) = ""

        ActiveCell.Offset(1, 0).Select

        ActiveSheet.Paste

        

    Loop

    

    

End Sub 

The code simply copies the formula down the one column and not across all 18 columns.

Thoughts?

if you need further information please ask.

This is the second stage of the problem is a way to reorganise the recreated data above! This data will have a maximum of 11 cells filled with 3 initials from the possible 18 columns. I then need to arrange the data so that the last 7 columns are deleted but the first 1 are filled with the data (skip blanks - which in excel does not do what it sounds like).