Bu konuyu kardeş site olarak gördüğüm başka bir sitede yayınlamıştım. O sitede jon206 kodlu kullanıcı gerekli kodu yazarak problemi halletti.Paylaşmak güzeldir felsefesinden hareketle ve kendisinin izni ile burada yayınlıyorum.
Kod:
Sub VerileriAktarimBasla()
'referanslardan microsoft excel ... object
'referanslardan microsoft activex data object ... library ekli olması gerekir..
'access veri tabanı ile excel dosyası anı klasörde olması gerekir..
'her iki tabloda birkaç değişiklik yaptım inceleyiniz..
Dim mRs As New ADODB.Recordset 'M amulmadde tablosu için recordset tanımlıyoruz
Dim hRs As New ADODB.Recordset 'H ammadde tablosu için recordset tanımlıyoruz
Dim xlsapp As New Excel.Application
Dim yol As String, Kul_Hamd As String, str As String
Dim m As Long, x As Long, y As Long
Dim knt As Long, knt2 As Long, Mamul_id As Long, SonSatir As Long
'Excel dosyanın Yolu Alıyoruz..
yol = CurrentProject.Path & "\Hesaplama Tablosu.xlsx"
'excel dosyasını akra planda yüklüyoruz..
xlsapp.Workbooks.Open yol
'excel'i arka planda açıyoruz..
xlsapp.Visible = False
'exceldeki yukardan ağaşıya doğru kaç satır olduğunu buluyoruz..
SonSatir = xlsapp.Range("B1048576", Range("B1048576").End(xlUp)).Row + 1
m = 4
Do While xlsapp.Cells(3, m) <> "" 'exel 3 satırdan ve m=4 cü kolondan başlamak üzere sağ doğru Mamulmaddeleri döngüye alıyoruz...
'tablomuzda aynı kayıt olup olmadığını 0 ve 1 olarak kontrol ediyoruz..
knt = DCount("*", "MAMULMADDE", "[Üretilen Mamul Adı]='" & Cells(3, m) & "' ")
If knt = 0 Then 'eğer 0=yok ise mrs.addnew ile yeni kayıt ekliyoruz..
'Mamulmadde tablomuza yeni kayıt yapmak için tablomuzu açıyoruz..
mRs.Open "mamulmadde", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
mRs.AddNew
Else 'kaydımız var ise güncelleme içinn açıyoruz
Mamul_id = DLookup("id_mamul", "mamulmadde", "[Üretilen Mamul Adı]='" & Cells(3, m) & "' ")
mRs.Open "select * from mamulmadde where id_mamul=" & Mamul_id, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
End If
'yeni kayıt ve eski kayıt için ortak alan güncellemesi
mRs("Üretilen Mamul Adı") = Cells(3, m).Value
mRs("miktarı") = CLng(Cells(4, m).Value)
mRs("birimi") = Cells(4, m + 1).Value
mRs.Update
Mamul_id = mRs(0) 'id numarasını tekrar alıyoruz.. ' hammadde için
mRs.Close
'hammede kayıdına geçiyoruz..
'------------------------------------------------
x = 5
y = m
Kul_Hamd = xlsapp.Cells(5, 1) 'kullanılan hammadde verisini alıyoruz 5 satırdaki
Do Until xlsapp.Cells(x, y).Row >= SonSatir
If x Mod 4 = 1 Then Kul_Hamd = xlsapp.Cells(x, 1) '5-9-13-17 satırdakikullanılan hammdde alıyoruz..
'mamul edilen ve hammedde eşit olan kaydı kontrol ediyoruz.. yok ise 0 varsa 1 ve üzeri ise güncelleme için
knt2 = DCount("*", "HAMMADDE", "id_mamul=" & Mamul_id & " and [kullanılan hammadde]='" & Kul_Hamd & "'")
If knt2 = 0 Then 'yok ise
hRs.Open "hammadde", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
hRs.AddNew 'yeni kayıt ekle diyoruz..
hRs("id_mamul") = Mamul_id
hRs("üretilen mamul adı") = xlsapp.Cells(3, m)
hRs("kullanılan hammadde") = Kul_Hamd
hRs("bir#kul#mkt(kg)") = xlsapp.Cells(x, y) '1
x = x + 1
hRs("fire (%)") = xlsapp.Cells(x, y) '2
x = x + 1
hRs("birim#kul#top#mkt") = xlsapp.Cells(x, y) '3
x = x + 1
hRs("mam#kul#top#mkt") = xlsapp.Cells(x, y) ' 4
hRs.Update
hRs.Close
Set hRs = Nothing
Else 'eski kayıt varsa güncelleme için ise
hRs.Open "select * from hammadde where id_mamul=" & Mamul_id & " and [kullanılan hammadde]='" & Kul_Hamd & "'", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
hRs("bir#kul#mkt(kg)") = xlsapp.Cells(x, y) '1
x = x + 1
hRs("fire (%)") = xlsapp.Cells(x, y) '2
x = x + 1
hRs("birim#kul#top#mkt") = xlsapp.Cells(x, y) '3
x = x + 1
hRs("mam#kul#top#mkt") = xlsapp.Cells(x, y) ' 4
hRs.Update
hRs.Close
Set hRs = Nothing
End If
x = x + 1
Loop
'---------- hammadde verilerin bitişi ----------------------------------------------------------
m = m + 3 'sonraki mamul mal geçmek için M değeri +3 ekliyoruz sebebi örng: 3 satırın d-e-f kolonlarını dikkate alırsak (E ve F) kolonun boş olmasıdır..
Loop
'excel dosyasını kapatıyoruz..
xlsapp.Workbooks.Close
xlsapp.Quit
Set mRs = Nothing
Set hRs = Nothing
MsgBox "Aktarım Tamamlanmıştır.."
End Sub