Macro to copy data in rows based on criteria

I am looking for help to write a simple macro. Starting on column B66 is the word "Short" below that in the next 20 cells I would like a macro to write the word "Long Basket". If the word was "Long" then I would like the macro to write the word "Short Basket" for the next 20 cells (ex:B130). I would like a macro to loop through every example and do this. Can anyone help with this? thanks!!

This should do it:

Option Explicit

Sub ShortLongBaskets()
Dim RNG As Range, LastRw As Long, Rw As Long
Application.ScreenUpdating = False

LastRw = Range("B" & Rows.Count).End(xlUp).Row

For Rw = 66 To LastRw Step 21
    Select Case LCase(Range("B" & Rw).Text)
        Case "short"
            Range("B" & Rw + 1).Resize(20, 1).Value = "Long Basket"
        Case "long"
            Range("B" & Rw + 1).Resize(20, 1) = "Short Basket"
    End Select
Next Rw

Application.ScreenUpdating = True
End Sub

Try this:

Option Explicit

Sub ShortLongBaskets()
Dim RNG As Range, rFind As Range
Dim LastRw As Long, Rw As Long
Application.ScreenUpdating = False

LastRw = Range("B" & Rows.Count).End(xlUp).Row

For Rw = 66 To LastRw Step 21
    Select Case LCase(Range("B" & Rw).Text)
        Case "short"
            Range("B" & Rw + 1).Resize(20, 1).Value = "Long Basket"
        Case "long"
            Range("B" & Rw + 1).Resize(20, 1) = "Short Basket"
    End Select
    Range(Range("F" & Rw + 1), Range("F" & Rw + 20)).FormulaR1C1 = _
        "=IF(INDEX(R7C27:R26C40, ROW(R[-" & Rw & "]C1), MATCH(R" & Rw & "C6, R6C27:R6C40, 0))=0,"""",INDEX(R7C27:R26C40, ROW(R[-" & Rw & "]C1), MATCH(R" & Rw & "C6, R6C27:R6C40, 0)))"
Next Rw

With Range("F:F")
    .Value = .Value
    .SpecialCells(xlCellTypeConstants, 16).Clear
End With

Application.ScreenUpdating = True
End Sub

If that takes care of your need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.