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
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"
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]
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ı
Referanslarınızda DAO ile ilgili bir referans var mı?
Varsa DAOlu referansı devre dışı bırakıp oyle dener misiniz
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?