Помогите с циклом!!!!

[klimpashka23]

Здравствуйте форумчане!!!Работаю над программой редактирования рассписания...есть рассписание предметов по дате,дню недели,и номеру пары..смотрите в примере....мне необходимо написать макрос который бы мог копировать нужные шифры на новый лист в шаблон,ориентируясь по дате,паре и дню недели...в принцыпе всё готово...только не получается задать цикл для поиска...

[klimpashka23]

а вот макрос


Sub Raspisanie()
Dim iRow As String
Dim jk As String
Dim VDate As Boolean
Search = "*?.??"


Inpu = InputBox("Введите шифр дисциплины")
MsgBox ("Вы ввели :" & Inpu)

Set MyRange = Range("A1:BT213")
WWSearch = Inpu
Set Srch = MyRange.Find(WWSearch)
If Not Srch Is Nothing Then
StartCell = Srch.Address

Do
iRow = Srch.Address
Range(StartCell).Offset(-1, 0).Select
Vid = ActiveCell.Value

Range(StartCell).Offset(1, 0).Select
Aud = ActiveCell.Value

Range(StartCell).Select
ParaNumber = Trim("$B$") & Mid(iRow, (InStr(2, iRow, "$")) + 1)


Range(ParaNumber).Select
Para = ActiveCell.Value

Range(StartCell).EntireRow.Select
DenNumber = Trim("$A$") & Mid(iRow, (InStr(2, iRow, "$") + 1))


Range(DenNumber).Select
Den = ActiveCell.Value



Range(StartCell).Activate
Do Until ActiveCell = IsDate(Search)

If ActiveCell.Offset(-1, 0) = "" Then
ActiveCell.Offset(-1, 0).Activate
End If

ActiveCell.Offset(-1, 0).Select
Set Src = Selection.Find(Search)


If IsDate(Src) Then

Idat = Src.Address
End If
Loop
Range(Idat).Select
Dat = ActiveCell.Value




Sheets("K2").Activate
Set Srk = Cells.Find(Den)
AddressDen = Srk.Address

Range(AddressDen).EntireRow.Select
Set Srj = Selection.Find(Para)
AddressPara = Srj.Address


Set Sr = MyRange.Find(Dat, LookAt _
:=xlWhole)
AddressData = Sr.Address


Mesto = Mid(AddressData, 2, (InStr(2, AddressData, "$")) - 2) & Mid(AddressPara, (InStr(2, AddressPara, "$")) + 1)
Range(Mesto).Select
ActiveCell.FormulaR1C1 = Vid
Range(Mesto).Offset(1, 0).Select
ActiveCell.FormulaR1C1 = Inpu
Range(Mesto).Offset(2, 0).Select
ActiveCell.FormulaR1C1 = Aud


Set Srch = MyRange.FindNext(Srch)

Loop While Not Srch Is Nothing And Srch.Address <> StartCell
End If
End Sub
Sub TsiklPoiska()
Dim iRow As String
Dim Inpu As String
Inpu = InputBox("Введите шифр дисциплины")
MsgBox ("Вы ввели :" & Inpu)

Set MyRange = Range("D11:AW22")
WWSearch = Inpu
Set Srch = MyRange.Find(WWSearch)
If Not Srch Is Nothing Then
StartCell = Srch.Address
Do
iRow = Srch.Address
Range(StartCell).Select
Den = ActiveCell.Value
Sheets("K2").Select
Range(StartCell).Select
ActiveCell.FormulaR1C1 = Den

Set Srch = MyRange.FindNext(Srch)

Loop While Not Srch Is Nothing And Srch.Address <> StartCell
End If
End Sub