Originariamente inviato da amodio
Private Sub Trasferisci()

Dim ExcelSheet As excel.Worksheet
Dim AppExcel As New excel.Application

AppExcel.Visible = True
Set cart = excel.Workbooks.Open(App.Path & "\prova.xls")

'ExcelSheet.SaveAs "c:\prova.xls"

'ExcelSheet.Range(ExcelSheet.Cells(2, 1), ExcelSheet.Cells(5, 3)).Select

If rs.State = 1 Then
rs.Close
End If


rs.Open StrSql, conn

AppExcel.Cells(1, 1) = "Data"
AppExcel.Cells(1, 2) = "Soggetto"
AppExcel.Cells(1, 3) = "Causale"
AppExcel.Cells(1, 4) = "Specifico Causale"
AppExcel.Cells(1, 5) = "Mezzo Pagamento"
AppExcel.Cells(1, 6) = "Oggetto"
AppExcel.Cells(1, 7) = "Valuta"
AppExcel.Cells(1, 8) = "Importo"


Dim i
Dim riga

i = 1 'iniizo dall seconda riga il primo è il titolo
riga = 3

Do While rs.EOF = False
'For riga = 1 To 2
i = 1
AppExcel.Cells(riga, i) = CStr(rs("Data"))
i = i + 1
AppExcel.Cells(riga, i) = rs("Soggetto")
i = i + 1
AppExcel.Cells(riga, i) = rs("Causale")
i = i + 1
AppExcel.Cells(riga, i) = rs("speccausale")
i = i + 1
AppExcel.Cells(riga, i) = rs("mezzo_pagamento")
i = i + 1
AppExcel.Cells(riga, i) = rs("Oggetto")
i = i + 1
AppExcel.Cells(riga, i) = rs("Valuta")
i = i + 1
AppExcel.Cells(riga, i) = rs("Importo")


'colonna
'

'Next riga
riga = riga + 1
rs.MoveNext
i = i + 1
' i
Loop



' rs.Close
ExcelSheet.SaveAs("C:\prova2.xls")
AppExcel.Quit
Set ExcelSheet = Nothing
Set AppExcel = Nothing

End Sub
Prova ad aggiungere la riga in rosso.
..certo che con 3 menti come le nostre al lavoro su questo problema, e' praticamente impossibile che il problema resti insoluto