Skip to main content

AccessTr.neT


Accessten Excele Dögüsel Veri Aktarımı

Accessten Excele Dögüsel Veri Aktarımı

#13
Dim XlAc As Excel.Application
    Dim XlKtp As Excel.Workbook
    Dim XlSyf As Excel.Worksheet
    Dim xRng As Excel.Range
burada tanımlama tüm nesneleri as object olarak değiştirip dener misiniz?
Dim XlAc As object
    Dim XlKtp As object
    Dim XlSyf As object
    Dim xRng As object
gibi
Cevapla
#14
Günaydın sayın berduş, sorun düzeldi sürüm farkından dolayı hata veriyordu. Katkılarınızdan dolayı teşekkür eder saygılarımı sunarım. İyi çalışmalar.
Cevapla
#15
Iyi çalışmalar)
Cevapla
#16
Sayın berduş hocam öncelikle saygılarımı sunar iyi çalışmalar dilerim. Yardımlarınızla yukarıdaki konuyu çözüme kavuşturduk. Kod aşağıdaki gibi. Ek olarak exccele aktarım yaparken excceldeki eski verileri nasıl sileriz. Yani sorgu sunucu boşsa excelleki eski kayıtlarıda silsin.Nasıl bir ekleme yapabiliriz.  Saygılarımla iyi çalışmalar.

Private Sub Komut10_Click() 'POZİTİF
Dim TabloAdi As String
Dim XlAd As String
Dim SyfAd As String


TabloAdi = "Srg_covit_EXCELL_POZATİF"
XlAd = CurrentProject.Path & "\Şablon.xlsx"
SyfAd = "POZİTİF" '& "$"

'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 [t_tcno],[AdıSoyadı],[t_mudrlük],[t_gorevyeri],[Yaşı],[t_ilce],[t_hastaneadi],[t_telefon] FROM Srg_covit_EXCELL_POZATİF" '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
''          İsterseniz aşağıdaki satırı da aktifleştrebilirsiniz
XlKtp.Save
XlAc.Quit

    Set XlAc = Nothing
    Set XlKtp = Nothing
    Set XlSyf = Nothing
'''Set xRng = Nothing
Cevapla
#17
(11/09/2020, 11:10)orderyazbim yazdı: XlSyf.Range("B2:Z" & SonStr).ClearContents
Bu kod silmek için kullanılmıştı. Bunu kullanarak silebilirsiniz
Cevapla
#18
Sayın hocam çok teşekkür eder saygılarımı sunarım.İyi çalışmalar....
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task