Accessten Excele Veri Aktarma

[atkinsonmuldo]

Merhaba,

Arkadaşlar benim sorum uzun süredir yanıtını bulamadığım accessten excele veri aktarma ile ilgili. Forumdaki örnekler benim sorumun yanıtı maalesef olamadı.

Ekte 1 access 1 de excel dosyası var. Amacım accessteki "Mükerrer", "Plan", "Terminli" querylerini yeni bir excel dosyası açıp, herbir query için excelde ayrı sayfalar açıp bu querylerin içindeki tabloları excel sayfalarına aktarabilmektir(son hali örnekteki excel dosyası gibi olması istiyorum). Bu bir formda 1 buton yolu ile olabilir. Umarım sorumu anlatabilmişimdir. Buna benzer bir problemi çözmüş ya da elinde örnek olan arkadaşlar paylaşabilirlerse çok sevinirim.

 

[mancubus]

access forumunda konu açmak daha uygun olacaktır.

Option Compare Database

Function AllTablesToSheets()
'http://www.access-programmers.co.uk/forums/showthread.php?t=191123

Dim i As Integer
Dim db As DAO.Database
Dim rs As DAO.Recordset
'Dim tbldef As TableDef
Dim xl As New Excel.Application
Dim wkbk As Excel.Workbook
Dim wksht As String

Dim qrys As DAO.QueryDefs
Dim qry As DAO.QueryDef
Set qrys = CurrentDb.QueryDefs

xl.Visible = True
xl.DisplayAlerts = False

Set db = CurrentDb
Set wkbk = xl.Workbooks.Add

With wkbk
    .SaveAs FileName:="C:\Users\kullanıcı_adı\Documents\access\dnm1.xls" 'kendi yol ve dosya isminize uyarlayın
    'LOOP THROUGH ALL TABLES
    'For Each tbldef In db.TableDefs
    For Each qry In qrys
        Set rs = db.OpenRecordset(qry.Name, dbOpenDynaset)
        wksht = qry.Name
        .Sheets.Add after:=Sheets(Sheets.Count)
        .Sheets(Sheets.Count).Name = wksht
        'WRITE FIELD NAMES
        For i = 0 To rs.Fields.Count - 1
        .Sheets(wksht).Cells(1, i + 1).Value = rs.Fields(i).Name
        Next
        .Sheets(wksht).Range(.Sheets(wksht).Cells(1, 1), _
        .Sheets(wksht).Cells(1, rs.Fields.Count)).Font.Bold = True
        'COPY THE TABLE
        .Sheets(wksht).Range("A2").CopyFromRecordset rs
    Next qry
    '.Sheets("sheet1").Delete
End With

xl.DisplayAlerts = True

rs.Close
xl.ActiveWorkbook.Save
wkbk.Close
xl.Quit

Set wkbk = Nothing
Set xl = Nothing
Set rs = Nothing
Set db = Nothing

End Function

 

[hımmmmmmmm]

slm

farklı sorgulama var ama bu örneklerde işini görür sanırım...

Dim CNN As Object, RST As Object

Public Sub BAGLA()
Set CNN = CreateObject("Adodb.connection")
CNN.Open "Provider=Microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\Deneme1.mdb"
End Sub

Public Sub SORGU1()
BAGLA
Set RST = CreateObject("Adodb.Recordset")
Set RST = CNN.Execute("SELECT * FROM Tablo1")
Range("A2").CopyFromRecordset RST
End Sub

 

[hımmmmmmmm]

slm

benim kullandığım komutlar bu şekilde... tool-references-active x data object 2.8 etkinleşecek

Dim CNN As ADODB.Connection
Dim RST As ADODB.Recordset



Public Sub BAGLA()
Set CNN = New ADODB.Connection
With CNN
     .Provider = "Microsoft.Jet.OLEDB.4.0;"
     .CursorLocation = adUseClient
     .Open (ThisWorkbook.Path + "\Deneme1.MDB")
End With

End Sub



Public Sub SORGULA()
BAGLA
   SORGU = "SELECT * FROM Tablo1"
   Set RST = New ADODB.Recordset
   RST.Open SORGU, CNN, adOpenKeyset, adLockOptimistic
   Range("A2").CopyFromRecordset RST
End Sub

 

[atkinsonmuldo]

Çok teşekkür ederim, örnekleri hemen deneyeceğim. Eğer problemi çözemezsem dediğiniz gibi access forumunda aynı başlıklı konuyu açacağım.

 

[mancubus]

Çok teşekkür ederim, örnekleri hemen deneyeceğim. Eğer problemi çözemezsem dediğiniz gibi access forumunda aynı başlıklı konuyu açacağım.

ben access temel bir çözüm aranıyor diye düşündüğüm için öyle yazmıştım.

benim verdiğim çözüm access makrosu zaten. problemsiz aktardı sorgu sonuçlarını.

 

[hımmmmmmmm]

slm

mancubus sanin yaptığın doğru...