Excel tablosundan veri aktarma

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