Do Until Application.CountBlank(Range(ActiveCell, ActiveCell.Offset(2))) = 3
   'Alguma coisa que mude a célula ativa para não ficar em loop infinito, por ex.:
   'ActiveCell.Offset(1).Activate
  Loop

Boa tarde EdsonBR
Como se aplicaria nesse código?
-------------------------------------------------
Sub Inserir_Tds_Composições()

Dim W As Worksheet

Application.ScreenUpdating = False

Set W = Sheets("Orçamento")

Do While ActiveCell.Value <> ""

If ActiveCell.Value <> "" Then
Selection.Copy
Workbooks("Banco.xlsm").Activate
Sheets("CATALOGO").Select
Range("B3").Select
ActiveSheet.Paste
Sheets("CATALOGO").Select
Range("C5").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Workbooks("orçamento.xlsx").Activate
Sheets("Comp_analiticas").Select
Range("A200000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(2, 0).Select
' ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
ActiveCell.Offset(2, 6).Select

'COLOCAR SOMATÓRIA

Dim UltimaLinha As Long
Dim S As Worksheet

Set S = Sheets("Comp_analiticas")

S.Range("G" & Rows.Count).End(xlUp).End(xlUp).Offset(2, 0).Select

If ActiveCell.Offset(1, 0).Value = "" Then GoTo Calcula

With ActiveCell
UltimaLinha = .End(xlDown).Row
.Resize(UltimaLinha - .Row + 1).Select

End With

Calcula:
CellAddr = Selection.Address
ActiveCell.Offset(-1, 0).Select
ActiveCell.Formula = "=SUM(" & CellAddr & ")"

'COLOCAR ITEMIZAÇÃO
ActiveCell.Offset(0, -6).Select
Sheets("Orçamento").Select
ActiveCell.Offset(0, -2).Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(0, 2).Select
Sheets("Comp_analiticas").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False

Sheets("Orçamento").Select

End If

If ActiveCell.Value = "" Then Exit Do
ActiveCell.Offset(1, 0).Select

Loop

Application.ScreenUpdating = True

MsgBox "Concluído"

End Sub

Do While ActiveCell.offset(2,0).Value <> ""