Guru do Excel e Power BI

Pessoal, boa noite

Estou criando uma macro para buscar informações do banco a partir da planilha "Busca" e colocar as informações no planilha "REsultado"

Ocorre que meu código não está chamando os proximos registros da planilha busca e quando cola na planilha "Resultado", cola na linha a seguir da quantidade de contratos buscados na planilha "Busca".

Segue o codigo e a tabela para poderem me apoiar

Private Sub CommandButton1_Click()


Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim fd As ADODB.field
Dim SQL As String
Dim ln As Long
Dim col As Integer
Dim w As Worksheet
Dim p As Worksheet
Dim ultCel As Range
Dim vbusca As String


Application.ScreenUpdating = False


'Selecionando os contratos
Set p = Sheets("Busca")
Set ultCel = p.Cells(p.Rows.Count, 1).End(xlUp)

p.Select
ln = 2
col = 2

Set w = Sheets("Resultado")
w.Select
w.UsedRange.EntireColumn.Delete

ln = 1
col = 1

Do While ln <= ultCel.Row
vbusca = p.Cells(ln, col)



'Iniciando a conexão

Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset

'ServerName 'Enter your server name here
'DatabaseName 'Enter your database name here
'UserID 'Enter your user ID here
'Password 'Enter your password here


conn.Open "Driver={SQL Server};Server=" & ServerName & ";Database=" & DatabaseName & ";Uid=" & UserID & ";Pwd=" & Password & ";"
conn.CommandTimeout = 60

SQL = "select NUMCTT, DATCTT, CODCLI, VLRVNDCTT from TB_ODSCTT"
SQL = SQL & " where RIGHT(NUMCTT,8) = (" & vbusca & ")"

Debug.Print SQL

rs.Open SQL, conn

ln = ln + 1

Loop


If Not rs.BOF And Not rs.EOF Then

'Inserindo Titulos
For Each fd In rs.Fields

w.Cells(ln, col) = fd.Name
col = col + 1

Next fd

col = 1
w.Cells(ln + 1, col).CopyFromRecordset rs
ln = ln + 1


End If

w.Range("A1:D1").Font.Bold = True
w.UsedRange.EntireColumn.AutoFit

rs.Close
conn.Close

w.Range("A1").Select

MsgBox "Processo Concluido"

Set w = Nothing
Set conn = Nothing
Set rs = Nothing
Set fd = Nothing
Set p = Nothing
Set ultCel = Nothing



Application.ScreenUpdating = True


End Sub