Guru do Excel e Power BI

Boa noite pessoal
Estou em bisca de uma solução para o seguinte problema: Preciso buscar o numero de contratos enquanti tiver informações dentro do range e colocar dentro da variavel "vBusca"

Como fazer? Alguma ideia?

A que eu fiz abaixo não está buscando as informações de forma correta

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

Boa tarde Pessoal

A ideia dessa macro é buscar informações do banco.

Consegui realizar todo o processo mas, preciso colocar os nomes das colunas acima da busca, isto é NUMCTT, DATCTT, CODCLI, VLRVNDCTT .

Alguém sabe como ajudar?

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 = 1

Set w = Sheets("Resultado")
w.Select
w.UsedRange.EntireColumn.Delete
ln = 2
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

w.Cells(ln - 1, col).CopyFromRecordset rs

Loop

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

Veja este exemplo

Xow de bola. Deu certo. Vlw

Basole escreveu:Veja este exemplo

Código: Selecionar todos

For i = 0 To rs.Fields.Count - 1
  Cells(1, i + 1).Value = rs.Fields(i).Name
Next
  ' * Se quiser em negrito:
 Range(Cells(1, 1), _
 .Cells(1, rs.Fields.Count)).Font.Bold = True

Basole escreveu: ↑15 Mar 2022 às 14:01 Veja este exemplo

Código: Selecionar todos

For i = 0 To rs.Fields.Count - 1
  Cells(1, i + 1).Value = rs.Fields(i).Name
Next
  ' * Se quiser em negrito:
 Range(Cells(1, 1), _
 .Cells(1, rs.Fields.Count)).Font.Bold = True

@Basole

Mto obrigado cara. Deu certo