А формулы не подойдут?  
Выделенное протягиваем вниз.

Сбор по всем листам (исключая активный):  
 
Sub tt()  
Application.ScreenUpdating = False  
   Dim sh As Worksheet  
   Dim cel&, i&  
   For Each sh In Sheets  
       If sh.Name <> Me.Name Then  
           For i = 1 To sh.Cells(Rows.Count, 1).End(xlUp).Row  
               If sh.Cells(i, 1).Value <> Empty Then  
                   cel = cel + 1  
                   sh.Range(sh.Cells(i, 1), sh.Cells(i, 3)).Copy _  
                   Me.Range(Me.Cells(cel, 1), Me.Cells(cel, 3))  
               End If  
           Next  
       End If  
   Next  
Application.ScreenUpdating = True  
End Sub