Попробуйте такой макрос:  
 
Sub test()  
   On Error Resume Next  
   Dim cell As Range, ra As Range: Application.ScreenUpdating = False  
   Set ra = Range([A2], Range("A" & Rows.Count).End(xlUp))
   For Each cell In ra.Cells  
       If Not IsDate(cell) Then  
           Intersect(cell.Next.Next.Resize(, 10), cell.Worksheet.UsedRange).Cut _  
                   cell(0, 1).EntireRow.Cells(Columns.Count).End(xlToLeft).Next  
           cell.Cut cell(0, 2)  
       End If  
   Next cell  
   Range("a:a").SpecialCells(xlCellTypeBlanks).EntireRow.Delete  
End Sub  
 
 
 
Пример в файле: http://excelvba.ru/XL_Files/Sample__19-04-2010__11-23-08.zip