Excelden Accesse Veri Alıp Gönderme

1 2 3 4 5 6 7 8 9 10 11
18/02/2021, 22:37

hayalibey

Berduş Hocam eliniz dert görmesin
Zafer Hocam sizin de eliniz dert görmesin
Kodu yarın ofiste deneyip sonuç hakkında size biligi vereyim.
Kandiliniz mübarek olsun. Rabbim de sizi ikinizi de Hocalarim hiç darda bırakmasın inşallah
18/02/2021, 22:47

berduş

hala bazı ufak tefek sorunlar var mesela Excel sayfasındaki silinmiş boş satırları bile alabiliyor
tablo kayıtlar eklendikten sonra boş satırları silme kodunu henüz ayarlayamadım
sayfaları accesse aktarmada yeni bir yöntem denedim dilerim işinize yarar
tabloları excele Aktarma kodu
Sub AccessAl(SyfAdiDz() As Variant)
    Dim AdoCon As ADODB.Connection
    Dim AdoRs As ADODB.Recordset
    Dim AdoSql As String
    VtAdi = ThisWorkbook.Path & "\YILDIZ_VeriTabanı.accdb"
    Set AdoCon = New ADODB.Connection
    AdoConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & VtAdi
    AdoCon.Open AdoConString

Dim Sht As Worksheet
Dim SonStn As Long
Dim SyfAdi As Variant
For Each SyfAdi In SyfAdiDz
    Set AdoRs = New ADODB.Recordset
    AdoSql = "Select * from " & SyfAdi

Set Sht = ThisWorkbook.Worksheets(SyfAdi)
    SonStn = Sht.Cells(1, Sht.Columns.Count).End(xlToLeft).Column
    SonStr = Sht.Cells(Sht.Rows.Count, 1).End(3).Column
xhrf = Split(Cells(1, SonStn).Address, "$")(1)
    Sht.Range("A2:" & xhrf & Sht.Rows.Count).Clear    ' .Cells(2, SonStn).Clear
    Set AdoRs = AdoCon.Execute(AdoSql)
    Sht.Range("A2").CopyFromRecordset AdoRs
   
    AdoRs.Close
Next

    AdoCon.Close
    Set AdoRs = Nothing
    Set AdoCon = Nothing
End Sub
accessten alınacak tabloların adını listeden alma kodu
Dim SyfAdiDz() As Variant
    SyfAdi = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then
            ReDim Preserve SyfAdiDz(SyfAdi)
            SyfAdiDz(SyfAdi) = ListBox1.List(i)
            SyfAdi = SyfAdi + 1
        End If
    Next i
Dim Name As Variant

AccessAl SyfAdiDz()
    MsgBox "aktarım tamam"
accesste var olan tabloları silme kodu
Function TabloSil(SilRs As Recordset, AccessConS As ADODB.Connection, ByVal SyfAdi As String)
            On Error Resume Next
            AccessSql = "DROP TABLE  " & SyfAdi
            Set SilRs = AccessConS.Execute(AccessSql)
End Function
sayfaları accesse aktarma kodu
    Dim AccessCon As ADODB.Connection
    Dim AccessRs As ADODB.Recordset
    Dim AccessSql As String
    VtAdi = ThisWorkbook.Path & "\YILDIZ_VeriTabanı.accdb"
    Set AccessCon = New ADODB.Connection
    AccessConString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & VtAdi
    AccessCon.Open AccessConString

'_________________________________________________
            Dim cn As ADODB.Connection
            Set cn = New ADODB.Connection
            VtAdi = ThisWorkbook.Path & "\YILDIZ_VeriTabanı.accdb"
            cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 8.0"
'_________________________________________________________
    Set AccessRs = New ADODB.Recordset
   
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then
            SyfAdi = ListBox1.List(i)
            TabloSil AccessRs, AccessCon, SyfAdi
            cn.Execute "SELECT * INTO [" & SyfAdi & "] IN '" & VtAdi & "' FROM [" & SyfAdi & "$];"

        End If
    Next i
            cn.Close
            Set cn = Nothing
            MsgBox "aktarım tamam"
19/02/2021, 01:59

berduş

son hali aşağıdadır boş kayıtları almaması için kriter ekledim
yalnız 2 yerde sorun çıktı
1 - hala bazı sütun başlıklarında "." Nokta var; aktarmada sorun çıkarmasa da dikkatli olun
2 - hatırlatma sayfanız sorunlu sütun başlıkları arasında tarih alanı var o sütunları sildim dikkatli olun
dilerim işinize yarar
Not: veritabanınız eklenip/silinen her tablo/kayıttan sonra şişer henüz sıkıştır/onar kodunu ekleyemediğimden şimdilik sizin accessi açıp sıkıştır/onar yapmanz uygun olur
Kriter ekleme kodu
Function BosKytOlcut(Syf As Worksheet) As String
Dim Hcr As Range, AlanAdi As Range
Dim SonStnHrf As String
SonStnHrf = Syf.UsedRange.Address
Set AlanAdi = Syf.Range("A1:" & Split(SonStnHrf, "$")(3) & "1")
For Each Hcr In AlanAdi.Cells
If Len(Hcr.Value & "") > 0 Then BosKytOlcut = BosKytOlcut & " & [" & Hcr.Value & "]"
Next Hcr
End Function
accesse aktarma kodunda yapılan değişiklikler
            Set Syf = Worksheets(SyfAdi) 
Krtr = BosKytOlcut(Syf)
Krtr = " where len(" & "'' " & Krtr & ")>0"
Krtr = Replace(Krtr, ".", "#")
cn.Execute "SELECT * INTO [" & SyfAdi & "] IN '" & VtAdi & "' FROM [" & SyfAdi & "$]" & Krtr & ";" '[" & SyfAdi & "$A1:AL20]
19/02/2021, 11:29

hayalibey

Hocam accessten Excel e aktar derken
Function TabloSil(SilRs As Recordset, AccessConS As ADODB.Connection, ByVal SyfAdi As String)
Kısmında

Excelden accesse aktar derken
Dim AccessCon As ADODB.Connection

Kısımlarını göstererk hata veriyor

Referansı da ekledim ama sizin dosyada çalışan kofu kendi dosyama alırken hata veriyor
Hatta şöyle yaptım.
Userformu direkt sizden aldım
Modülü tamamen kopyalayıp yapıştırdım. Yine olmadı
19/02/2021, 11:53

berduş

Referanslarınızda DAO ile ilgili bir referans var mı?
Varsa DAOlu referansı devre dışı bırakıp oyle dener misiniz
19/02/2021, 12:00

berduş

Gönderdiğim dosya sizde çalışıyor mu?
Eğer çalışıyorsa dosyanizdaki sayfaları gönderdiğim dosyaya ekleyip orada dener misiniz.
Bu arada ofis sürümünüz ne?
1 2 3 4 5 6 7 8 9 10 11