Dear Jamal,
Coba ganti prosedur SendToDB menjadi :
(bagian yang hijau adalah tambahan untuk cek keberadaan data excel dalam
database)
(bagian merah adalah tambahan untuk sedikit memastikan keberadaan koneksi
dan proses drop varibel dari memory)
'contoh insert into ke access memanfaatkan adodb
'pastikan library Microsoft ActiveX Data Object telah terinstall dikomputer
Public Sub SendToDB(Optional bState As Boolean = False)
Dim con As Object, rs As Object
Dim sCon As String, sQuery As String, sQCek As String
Dim rngQuery As Range, rng As Range
Dim lRec As Long, lCount As Long
Dim dblProc As Double
With Sheet1
lRec = WorksheetFunction.CountA(.Range("a1").EntireColumn) - 1
If lRec < 1 Then
MsgBox "Tidak ada data"
Exit Sub
End If
dblProc = Timer 'set waktu
mulai
Set rngQuery = .Range("x11").Resize(lRec, 1) 'area teks
query data yang akan dikirim
.Range("x8").Copy rngQuery 'copy
formula template query data
.Calculate 'calculate
sheet
rngQuery.Value = rngQuery.Value 'di values
End With
'misal kirim ke db bernama contoh_tulis.mdb
'karena rm.mdb akan digunakan untuk contoh ambil data yang bisa jadi
nanti dibatasi jumlah baris excel
sCon = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\contoh_tulis.mdb" & ";"
& _
"Mode=Share Deny None;"
Set con = CreateObject("ADODB.Connection") 'init object
connection
Set rs = CreateObject("ADODB.Recordset") 'init object
recordset
With con
.Open sCon 'buka koneksi
If .State = 1 Then 'koneksi OK ?
lCount = 0
'query insert into
sQuery = "INSERT INTO GR " & _
"(GR,GR_Date,Arrival_No,Arrival_Time,Police_No,Lokasi,Variety,Gudang,Netto,Staff"
& _
",CVL,Decompose,Garbage,Abnormal,Young,Black,Green,Germinated,Telur,Rafaction,KA,QC)"
sQCek = "SELECT dt1.GR FROM GR as dt1 WHERE dt1.GR="
'query select untuk cek
For Each rng In rngQuery
If LenB(rng.Value) <> 0 Then
'ambil recordset berdasar GR nilai GR yang ada di sheet
'kolom GR di sheet (lompat 22 kolom kekiri dari kolom X)
'recordset dengan cursor keyset
rs.Open sQCek & "'" & rng.Offset(0, -22).Value & "'",
con, adOpenKeyset
If rs.RecordCount = 0
Then 'belum ada datanya ?
lCount = lCount +
1 'counter
.Execute sQuery & " " &
rng.Value 'tulis data baru
End If
rs.Close 'close
recordset
End If
Next rng
rngQuery.Delete xlShiftUp 'hapus kolom query
.Close 'tutup koneksi
End If
End With
Set con = Nothing 'drop variabel dari memory
Set rs = Nothing 'drop variabel dari memory
dblProc = Timer - dblProc 'set
waktu selesai
MsgBox "Done." & vbCrLf & _
lCount & " record(s) in " & dblProc & " second", vbInformation,
"Insert Into"
End Sub
Cara lainnya adalah menyusun query insert dengan bagian select yang di left
atau right join dengan tabel di database berdasar kolom kuncinya yang
nilai kunci
di tabel databasenya bernilai NULL. Pada beberapa database engine, bisa
juga menggunakan Except query.
Wassalam,
Kid.
2012/10/25 Xanchel <[email protected]>
> **
>
>
> Dear om mr.Kid, om heru.
>
> maaf saya nyimpang pertanyaan om heru.
> saya coba klik upload "2x" ( klik upload setelah selesai saya klik lagi"
> terlihat data yg sama di upload sebanyak 2x. jika saya ingin supaya sebelum
> upload, check data yg ada di .mdb dan upload hanya yg belum ada saja di
> .mdb bagaiaman ya om ?
>
> salam.
> Jamal
>
>
>
