referanslardan Microsoft Excel Object Library eklenmeli
buton kodu
Dim TabloAdi As String
Dim XlAd As String
Dim SyfAd As String
TabloAdi = "isimler"
XlAd = CurrentProject.Path & "\Deneme.xlsx"
SyfAd = "isimler" '& "$"
'hy Excele sayfasına verileri biçimli aktarma_____________________________
Dim dbs As DAO.Database
Dim rsSQL As DAO.Recordset
Dim StrAna As String
Set dbs = CurrentDb
StrAna = "SELECT [adi],[soyadi],[yaşı],[ilçe] FROM isimler" 'ya alanların ismi tek tek yazılacak yada _
sadece gerekli alanların olduğu bir sorgu oluşturup oradan select * diyeceksiniz
Set rsSQL = dbs.OpenRecordset(StrAna, dbOpenSnapshot)
If rsSQL.RecordCount > 0 Then
rsSQL.MoveLast
rsSQL.MoveFirst
Else
Exit Sub
End If
'hy Exceli aç
Dim XlAc As Excel.Application
Dim XlKtp As Excel.Workbook
Dim XlSyf As Excel.Worksheet
Dim xRng As Excel.Range
Dim SonStr As Long
Set XlAc = CreateObject("Excel.Application")
Set XlKtp = XlAc.Workbooks.Open(XlAd)
Set XlSyf = XlKtp.Worksheets(SyfAd)
XlAc.Visible = False
SonStr = XlSyf.Cells(XlSyf.Rows.Count, 2).End(xlUp).row + 1 'XlAc.UsedRange.Rows(XlAc.UsedRange.Rows.Count).row
Debug.Print SonStr
XlSyf.Range("B2:Z" & SonStr).ClearContents
XlSyf.Range("B2").CopyFromRecordset rsSQL
rsSQL.Close
Set rsSQL = Nothing
'XlSyf.Range("A1").CurrentRegion.Select
Set xRng = XlAc.Selection
With xRng
' .Columns.AutoFit
' .Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlContinuous ', Weight:=xlThick
End With
XlKtp.Save
XlAc.Quit
Set XlAc = Nothing
Set XlKtp = Nothing
Set XlSyf = Nothing
Set xRng = Nothing
MsgBox "Excele Aktarma bitti"
