Relatório No Excel Com Parametros Sql

[melissa_ff]

So esta inserindo no excel o ultimo registro

Public Function relatoriosemana()

Dim xlApp As Excel.Application

Dim xlWork As Excel.Workbook

Dim xlSheet As Excel.Worksheet

Dim ssql As String

Dim rela As QueryDef

On Error GoTo GerarPlanilha

Screen.MousePointer = vbHourglass

MsgBox "Gerando relatório..."

Set xlApp = CreateObject("EXCEL.Application")

Set xlWork = xlApp.Workbooks.Open("C:\Documents and Settings\melissa\Usr\vb\AgendaDia.xls")

Set xlWork = xlApp.Workbooks(1)

Set xlSheet = xlApp.Worksheets("Dados")

Set rela = db.QueryDefs("Relatorio")

ssql = "SELECT [telefone].Data,[telefone].nome,[telefone].tel,[telefone].ligacao into asemanal FROM [telefone]"

ssql = ssql & "WHERE [telefone].Data Between [Data inicial] AND [Data Final]"

With rela

.SQL = ssql

.Parameters("Data inicial") = frmreladia.cmbdia1

.Parameters("Data final") = frmreladia.cmbdia2

.Execute

Do While Not frmreladia.Data1.Recordset.EOF

xlSheet.Cells(5, 1) = Format(frmreladia.Data1.Recordset("data"), "mm/dd/yyyy")

xlSheet.Cells(5, 1).Borders.LineStyle = 3

xlSheet.Cells(5, 1).Borders.Weight = 1

xlSheet.Cells(5, 1).Font.Name = "Verdana"

xlSheet.Cells(5, 1).Font.Size = 7

xlSheet.Cells(5, 2) = frmreladia.Data1.Recordset("Nome")

xlSheet.Cells(5, 2).Borders.LineStyle = 3

xlSheet.Cells(5, 2).Borders.Weight = 1

xlSheet.Cells(5, 2).Font.Name = "Verdana"

xlSheet.Cells(5, 2).Font.Size = 7

xlSheet.Cells(5, 3) = frmreladia.Data1.Recordset("Tel")

If bCinza Then xlSheet.Cells(5, 3).Interior.ColorIndex = 15

xlSheet.Cells(5, 3).Borders.LineStyle = 3

xlSheet.Cells(5, 3).Borders.Weight = 1

xlSheet.Cells(5, 3).Font.Name = "Verdana"

xlSheet.Cells(5, 3).Font.Size = 7

xlSheet.Cells(5, 4) = frmreladia.Data1.Recordset("Ligacao")

If bCinza Then xlSheet.Cells(5, 4).Interior.ColorIndex = 15

xlSheet.Cells(5, 4).Borders.LineStyle = 3

xlSheet.Cells(5, 4).Borders.Weight = 1

xlSheet.Cells(5, 4).Font.Name = "Verdana"

xlSheet.Cells(5, 4).Font.Size = 7

frmreladia.Data1.Recordset.MoveNext

Loop

End With

db.QueryDefs.Delete "Relatorio"

xlWork.Close True

xlApp.Quit

Set xlApp = Nothing

GerarPlanilha:

Select Case Err

Case 0

MsgBox "Pronto"

Screen.MousePointer = vbNormal

MsgBox "Relatório gerado com sucesso.", vbOKOnly + vbInformation

Shell "C:\Arquivos de programas\Microsoft Office\Office\excel.exe \\melissa\Usr\vb\AgendaDia.xls"

Case 1004

Unload frmreladia

MsgBox "Pronto"

Screen.MousePointer = vbNormal

MsgBox "O caminho não foi encontrado, por favor mude o caminho" & Chr(13) & " nas configurações e tente gerar o mapa novamente!", vbCritical + vbOKOnly

xlWork.Close True

xlApp.Quit

Set xlApp = Nothing

Case Else

MsgBox "Pronto"

Screen.MousePointer = vbNormal

MsgBox Err.Number & "-" & Err.Description, vbCritical + vbOKOnly

End Select

End Functi

[Manwë Súlimo]

Está inserindo só o ultimo registro porque você ta sobrescrevendo eles cada vez que insere um novo...

veja bem, se você sempre escreve sempre na celula (5,1) cada vez que o loop passar por ela ele vai colocar o valor atual do recordset, e sobrescrever o que está na celula

para não acontecer isso, use variaveis de controle, por exemplo V e H, e en cada loop, como a linha vai ter que decer na planilha, você coloca H=H+1, assim sempre vai ficar um linha abaixo...

até mais

[William Rodrigues]

Muito bem Manwë Súlimo

Ótima explicação e conclusão dos fatos

Abraços,

William Rodrigues