Последовательный перенос диапазонов - VBA

Формулировка задачи:

Уважаемые профи подскажите с доработкой макроса идея есть но совсем все плохо у меня с диапазонами... Задача такая : нужно последовательно скопировать диапазоны(сначала зеленый, потом красный , потом оранжевый и тд) на другой лист(можно в этой же книге).Описываю свой сценарий: 0)из книги в которой макрос(основная) обращаюсь к книге в которой диапазоны(first) 1)ищу дату 2)определяю адрес ячейки c первой датой 3)копирую диапазон который под этой датой(до первой пустой строки- выделена желтым)- на лист2 4)перехожу ко второму диапазоны этой даты на лист3 5)перехожу к другой дате и тд. У меня получилось только найти адрес ячейки с первой датой когда пыталась работать с диапазоном то постоянно вывались ошибка application defined or object defined error вот такой макрос у меня получается:

                    Листинг программы
                
 
                        
                          
                    
Sub tt()
Dim f  As Range
Dim x As String
Dim dat1 As Date
Dim sh As Worksheet
Set sh = Sheets("Base")
dat1 = Cells(1, 1)
'0)из книги в которой макрос(основная) обращаюсь к книге в которой диапазоны(first)
With Workbooks("first.xlsx").Sheets("Лист1") 
'1)ищу дату
Set f = .Columns("A:A").Find(dat1, , xlValues, xlWhole) 
If f Is Nothing Then
MsgBox "NO"
Else
End If
'2)определяю адрес ячейки c первой датой
x = f.Address 
'3)копирую диапазон который под этой датой(до первой пустой строки- выделена желтым) - здесь Cells(Rows.Count, "I").End(xlUp) выделяет весь имеющийся диапазон а нужно только тот который начинается со следующей строки после даты и до желтой строки. Здесь и пишет ошибку
.Range(Range(x).Offset(1, 0), Cells(Rows.Count, "I").End(xlUp)).Copy  
 
End With
 
End Sub

Заранее спасибо! с Диапазонами (особенно нахождение последних строк(ячеек)) беда - не тяну их)

Решение задачи: «Последовательный перенос диапазонов»

textual
                            Листинг программы 
                        
 
                        
                          
                    
Sub tt()
Dim f  As Range
'Dim r As Range
'Dim g As Range
'Dim y As Range
'Dim x As String
Dim dat1 As Date
'Dim sh As Worksheet
'Set sh = Sheets("Base")
dat1 = Cells(1, 1)
With Workbooks("first.xlsx").Sheets("Лист1")
Set f = .Columns(1).Find(dat1, , xlValues, xlWhole)
If f Is Nothing Then: MsgBox "NO": Exit Sub
.Range(.Cells(f.Row + 1, "a"), .Cells(f.End(xlDown).Row, "I")).Copy
End With
End Sub