Ghi và lấy dữ liệu giữa Access Và Excel

  • Thread starter Thread starter mrtq_86
  • Ngày gửi Ngày gửi
Liên hệ QC
Thêm hàm tạo file CSDL backup
Mã: 
Function fMakeBackup() As Boolean

    Dim Source As String
    Dim Target As String
    Dim retval As Integer
    Dim CheckExists As Boolean


    Source = ThisWorkbook.Path & "\GCSCAK.accdb"


    Target = ThisWorkbook.Path & "\Backup\GCSCAK"
    Target = Target & Format(Date, "mm-dd") & ".accdb"
    'Target = Target & Format(Time, "hh-mm") & ".accdb"
    
    ' create the backup
    retval = 0
    Dim objFSO As Object
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    CheckExists = objFSO.FileExists(Target)
    If CheckExists = True Then
        'Call objFSO.deletefile(Target)
        objFSO.deletefile (Target)
        'MsgBox ("da xoa")
    Else
        MsgBox ("The file does not exist")
    End If
    retval = objFSO.CopyFile(Source, Target, True)
    Set objFSO = Nothing


End Function
 
mrtq_86 đã viết:
Thêm hàm tạo file CSDL backup
Mã: 
Function fMakeBackup() As Boolean

    Dim Source As String
    Dim Target As String
    Dim retval As Integer
    Dim CheckExists As Boolean


    Source = ThisWorkbook.Path & "\GCSCAK.accdb"


    Target = ThisWorkbook.Path & "\Backup\GCSCAK"
    Target = Target & Format(Date, "mm-dd") & ".accdb"
    'Target = Target & Format(Time, "hh-mm") & ".accdb"
    
    ' create the backup
    retval = 0
    Dim objFSO As Object
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    CheckExists = objFSO.FileExists(Target)
    If CheckExists = True Then
        'Call objFSO.deletefile(Target)
        objFSO.deletefile (Target)
        'MsgBox ("da xoa")
    Else
        MsgBox ("The file does not exist")
    End If
    retval = objFSO.CopyFile(Source, Target, True)
    Set objFSO = Nothing


End Function
Nhấp chuột vào đây để mở rộng...

oh cái đồng chí này cũng dị mọ vậy ta ...đồng chí học ở Sóc Sơn, Sơn Tây, đường bê tông Thanh Xuân, Cổ Nhuế ...hay thủ đức vậy
mà mấy chỗ đó nó chỉ dạy tin học có 10 mấy cặp tiết à .....khâm phục tinh thần tự học ...--=0
 
Hỏi ông Google hết mà =))
 
kieu manh đã viết:
bạn thử nghiên cứu DAO xem ghi dữ liệu từ Excel vào File Access nghe nói nhanh lắm đó code lại ngắn nữa ko biết sao
Nhấp chuột vào đây để mở rộng...


Dùng ADO cũng nhanh mà, Code nhiều là do mình dùng thêm hàm kiểm tra bắt lỗi thôi.

Mã: 
Option Explicit

Sub AddData()
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
Dim myPathAcc As String
Dim myPathExl As String
Dim answer As Integer
Dim acc As New Access.Application
Dim table As Variant


myPathExl = Application.ActiveWorkbook.FullName
myPathAcc = ThisWorkbook.Path & "\KTCSK.accdb"


cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myPathExl & ";Extended Properties=Excel 12.0;" _
& "Persist Security Info=False"


'your code here
Dim LastRow As Long
Set table = Nothing
showInputBox:
table = Application.InputBox("Nhap ten CSDL de ghi:", "GHI CSDL", "tbl" & ActiveSheet.name)
If table = False Then
    Exit Sub
ElseIf table = "" Then
        GoTo showInputBox
Else
Dim tbl As ListObject
    If TableExists(table) = True Then
        With ActiveSheet
            LastRow = .Cells(.Rows.Count, "O").End(xlUp).Row
        End With
        cn.Execute "Delete * from " & table & " IN '" & myPathAcc & "'"
        cn.Execute "INSERT INTO " & table & " IN '" & myPathAcc & "' SELECT * FROM [" & ActiveSheet.name & "$B5:O" & LastRow & "]"
        'cn.Execute "INSERT INTO " & table & " IN '" & myPathAcc & "' SELECT * FROM [PX14$B5:O53]"
        cn.Close
        Set cn = Nothing
        MsgBox ("CSDL" & table & " da duoc luu."), vbInformation
    Else
        MsgBox ("CSDL: " & table & " khong ton tai")
        answer = MsgBox("Ban co muon tao bang CSDL: " & table, vbYesNo + vbQuestion, "Tao bang CSDL")
        If answer = vbYes Then
            CreateTable
        Else
            Exit Sub
        End If
    End If
End If
End Sub

Ở đây mình thêm phần tìm dòng cuối của bảng để add vào CSDL, dữ liệu ngoài bảng bỏ qua
Mã: 
With ActiveSheet
            LastRow = .Cells(.Rows.Count, "O").End(xlUp).Row
        End With
        cn.Execute "Delete * from " & table & " IN '" & myPathAcc & "'"
        cn.Execute "INSERT INTO " & table & " IN '" & myPathAcc & "' SELECT * FROM [" & ActiveSheet.name & "$B5:O" & LastRow & "]"
 
Chú ý: khi có lỗi trong câu lện SQL có thể là CSDL chưa được kết nối.
khi truy vấn CSDL cần gọi kết nối
If cnn.State <> 1 Then Moketnoi
Your code here

Exit sub
 
mrtq_86 đã viết:
Dùng ADO cũng nhanh mà, Code nhiều là do mình dùng thêm hàm kiểm tra bắt lỗi thôi.

Mã: 
Option Explicit

Sub AddData()
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
Dim myPathAcc As String
Dim myPathExl As String
Dim answer As Integer
Dim acc As New Access.Application
Dim table As Variant


myPathExl = Application.ActiveWorkbook.FullName
myPathAcc = ThisWorkbook.Path & "\KTCSK.accdb"


cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myPathExl & ";Extended Properties=Excel 12.0;" _
& "Persist Security Info=False"


'your code here
Dim LastRow As Long
Set table = Nothing
showInputBox:
table = Application.InputBox("Nhap ten CSDL de ghi:", "GHI CSDL", "tbl" & ActiveSheet.name)
If table = False Then
    Exit Sub
ElseIf table = "" Then
        GoTo showInputBox
Else
Dim tbl As ListObject
    If TableExists(table) = True Then
        With ActiveSheet
            LastRow = .Cells(.Rows.Count, "O").End(xlUp).Row
        End With
        cn.Execute "Delete * from " & table & " IN '" & myPathAcc & "'"
        cn.Execute "INSERT INTO " & table & " IN '" & myPathAcc & "' SELECT * FROM [" & ActiveSheet.name & "$B5:O" & LastRow & "]"
        'cn.Execute "INSERT INTO " & table & " IN '" & myPathAcc & "' SELECT * FROM [PX14$B5:O53]"
        cn.Close
        Set cn = Nothing
        MsgBox ("CSDL" & table & " da duoc luu."), vbInformation
    Else
        MsgBox ("CSDL: " & table & " khong ton tai")
        answer = MsgBox("Ban co muon tao bang CSDL: " & table, vbYesNo + vbQuestion, "Tao bang CSDL")
        If answer = vbYes Then
            CreateTable
        Else
            Exit Sub
        End If
    End If
End If
End Sub

Ở đây mình thêm phần tìm dòng cuối của bảng để add vào CSDL, dữ liệu ngoài bảng bỏ qua
Mã: 
With ActiveSheet
            LastRow = .Cells(.Rows.Count, "O").End(xlUp).Row
        End With
        cn.Execute "Delete * from " & table & " IN '" & myPathAcc & "'"
        cn.Execute "INSERT INTO " & table & " IN '" & myPathAcc & "' SELECT * FROM [" & ActiveSheet.name & "$B5:O" & LastRow & "]"
Nhấp chuột vào đây để mở rộng...

Code Viết thuần ADO mình coi giờ cũng biết chút ...Tuy nhiên cái trường phái nhìn code như mớ rau trộn đó nhìn thấy code là thấy ngại ...-\\/.

Sau 1 tuần học thì giờ Mình viết nhét vào Access vào lấy ra tốt rồi và code ngắn gọn...Mọi cái mình thích nhét hết nó vào mảng xong ghi vào

Tuy nhiên hoc xong cái này nó lại phát sinh cái khác là xử cái mớ dữ liệu đó trong Access như thế nào ....giờ lại học tiếp mối quan hệ gì gì đó ....mệt

Bạn có thể tham khảo thêm code Mạnh Viết
Mã: 
Private Function GetConnection(ByVal AccPath As String)
    GetConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & AccPath
End Function
Rem ==========
Private Sub InsertDatabase(ByVal AccPath$, ByVal TableName$, ByVal Sh As Worksheet)
    Dim i As Long, j As Long, k As Long
    Dim Rst As ADODB.Recordset, Cnn As String, Arr()
    Arr = Sh.Range("E2:L20").Value
    Cnn = GetConnection(AccPath)
    Set Rst = New ADODB.Recordset ''Tools Check References ...Recordset 2.8
    Rem neu cho tham so 3,4 vao la loi code ...???!!!
    Rst.Open TableName, Cnn, adOpenStatic, adLockOptimistic
    For i = 1 To UBound(Arr, 1)
        If Arr(i, 2) <> "" Then
            Rst.AddNew
            For j = 1 To 4
                Rst.Fields(j) = Arr(i, j)
            Next
        End If
    Next
    Rst.Update
    Rst.Close
    Beep
End Sub
Rem ==========
Private Sub Main()
    Dim AccPath As String, Table As String
    Table = "Manh" ''ten Table trong Access
    AccPath = ThisWorkbook.Path & "\Data.accdb"
    Call InsertDatabase(AccPath, Table, Sheet2)
End Sub
Rem ==========
Public Sub DeleteTable(ByVal AccPath As String, ByVal TableName As String)
    Dim Engine As Object
    Set Engine = CreateObject("DAO.DBEngine.120")   ''36 Or 120
    Set Engine = DBEngine(0).OpenDatabase(AccPath)
    Engine.Execute ("DELETE * FROM " & TableName)
    Engine.Close
    Set Engine = Nothing
End Sub
Rem ==========
Public Sub Main_DeleteTable()
    Dim AccPath As String, Table As String
    Table = "Manh"
    AccPath = ThisWorkbook.Path & "\Data.accdb"
    Call DeleteTable(AccPath, Table)
End Sub

[COLOR=#ff0000][B] Khuyến mãi thêm hàm lấy dữ liệu sử dụng DAO nè[/B][/COLOR] ...--=--

Rem ==========
Public Sub GetDataBase(ByVal AccPath As String, ByVal TableName As String, ByVal Target As Range)
    Dim db As DAO.Database, Rst As Object
    Set db = DBEngine.Workspaces(0).OpenDatabase(AccPath)
    Set Rst = db.OpenRecordset("SELECT * FROM " & TableName)
    Target.CopyFromRecordset Rst
    Set db = Nothing
End Sub
Rem ==========
Public Sub Main_GetDataBase()
    Dim AccPath As String, Table As String
    Table = "Manh"
    AccPath = ThisWorkbook.Path & "\Data.accdb"
    Call GetDataBase(AccPath, Table, [A2])
End Sub
Rem ==========
Public Sub Check_DAO350DLL()
    On Error GoTo Thoat
    ThisWorkbook.VBProject.References.AddFromGuid _
    GUID:="{00025E01-0000-0000-C000-000000000046}", Major:=4, Minor:=0
Thoat:     ''Neu chay len 2 la loi nen Bay loi
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
E có 1 vấn đề này mong các bác giúp:
E có 1 File Access xuất ra từ phần mềm Etabs có đuôi “*.mdb” và 1 File Excel. E muốn nhập dữ liệu từ File “*.mdb” vào các Sheets của File Excel. E dùng chức năng Recorder macro để mò Code thì e được 1 đoạn Code miêu tả quá trình nhập dữ liệu từ File “*.mdb” vào 1 Sheet của File Excel trên.
Nhưng vấn để nảy sinh là: Cái “Data Source” nó lại là cố định ứng với vị trí e để File “*.mdb” đó. Bác nào viết giúp e đoạn Code để e gán vào 1 Nút sao cho khi e Click vào nút đó thì nó hiện ra 1 cửa sổ để e chọn đến vị trí của File “*.mdb” bất kỳ với! Như vậy thì sẽ linh động hơn nhiều là để File “*.mdb” tại 1 vị trí cố định.

Đoạn Code mà máy Recoder được:
Sheets("Frame Section Properties").Select
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\ThepCot.mdb;Mode" _
, _
"=Share Deny Write;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";" _
, _
"Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions" _
, _
"=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Co" _
, _
"py Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("Frame Section Properties")
.Name = "ThepCot"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\ThepCot.mdb"
.Refresh BackgroundQuery:=False
End With

Em xin chân thành cảm ơn!
 
sinhvientt đã viết:
E có 1 vấn đề này mong các bác giúp:
E có 1 File Access xuất ra từ phần mềm Etabs có đuôi “*.mdb” và 1 File Excel. E muốn nhập dữ liệu từ File “*.mdb” vào các Sheets của File Excel. E dùng chức năng Recorder macro để mò Code thì e được 1 đoạn Code miêu tả quá trình nhập dữ liệu từ File “*.mdb” vào 1 Sheet của File Excel trên.
Nhưng vấn để nảy sinh là: Cái “Data Source” nó lại là cố định ứng với vị trí e để File “*.mdb” đó. Bác nào viết giúp e đoạn Code để e gán vào 1 Nút sao cho khi e Click vào nút đó thì nó hiện ra 1 cửa sổ để e chọn đến vị trí của File “*.mdb” bất kỳ với! Như vậy thì sẽ linh động hơn nhiều là để File “*.mdb” tại 1 vị trí cố định.

Đoạn Code mà máy Recoder được:
Sheets("Frame Section Properties").Select
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=C:\ThepCot.mdb;Mode" _
, _
"=Share Deny Write;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";" _
, _
"Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions" _
, _
"=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Co" _
, _
"py Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("Frame Section Properties")
.Name = "ThepCot"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\ThepCot.mdb"
.Refresh BackgroundQuery:=False
End With

Em xin chân thành cảm ơn!
Nhấp chuột vào đây để mở rộng...
Thay vì nhập từ Access qua Excel .... thì từ Excel lấy access qua đi cho nó đơn giản gọn nhẹ khỏi rắc rối
 
kieu manh đã viết:
Thay vì nhập từ Access qua Excel .... thì từ Excel lấy access qua đi cho nó đơn giản gọn nhẹ khỏi rắc rối
Nhấp chuột vào đây để mở rộng...
Nhưng bảng Excel là bảng tihns của e mà, e phải lấy dữ liệu qua Sheet của Excel thì mới có thông số để tính toán được ạ!
Cái Code trên là e dùng chức năng Recorder macro nên khi e chọn tới đường dẫn File mdb thì đường dẫn đó là cố định, có cách nào để cái File mdb đó nó có thể ở vị trí bất kỳ ko ạ? Vì mỗi 1 bảng tính của e lưu trong 1 Folder khách nhau mà!
E cảm ơn!
 
Bạn vào góc "Lập Trình với Excel", tìm bài "Tổng Quan về FileSystemObject"
Chịu khó đọc đến đoạn có code chỉ cho bạn cách chọn lựa files.
 
VetMini đã viết:
Bạn vào góc "Lập Trình với Excel", tìm bài "Tổng Quan về FileSystemObject"
Chịu khó đọc đến đoạn có code chỉ cho bạn cách chọn lựa files.
Nhấp chuột vào đây để mở rộng...
Các bác viết Code kiểu gì mà nó không bị lỗi Font ra cái mặt cười vậy ạ? E thấy đoạn mã các bác post lên thường được bao trong 1 cái khung, mình chọn cái khung đó ở đâu khi post bài ạ?
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
0
Đọc
39
Việt Nguyễn 86
Việt Nguyễn 86
K
Mong giúp dữ liệu từ trang web sang excel
Trả lời
0
Đọc
46
khanhvinhdai1
K
GPE-Trợ Lý
[GPE] TALK SHOW EXCEL TRONG SẢN XUẤT
    • Thích
Trả lời
0
Đọc
435
GPE-Trợ Lý
GPE-Trợ Lý
T
Bảng tính trợ cấp tinh giản biên chế theo NĐ 108
    • Thích
Trả lời
3
Đọc
1K
trung_bhxh
T
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
Trả lời
0
Đọc
53
trung_bhxh
T
L
Viết phần mềm đánh lô bằng Visual Basic
    • Thích
2 3
Trả lời
52
Đọc
103K
khanhvinhdai1
K
Mewwo98
Thay dấu ngăn cách sau chữ số hàng nghìn, hàng triệu, hàng tỷ trong Mail Merge
Trả lời
5
Đọc
101
ptm0412
ptm0412
Huyen9
Lỗi không mailings được.
Trả lời
3
Đọc
77
vanle33
vanle33
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
310
Đọc
23K
kunkoi9390
K
K
Có ai giúp mình lấy kết quả xổ số miền nam về file excel
Trả lời
0
Đọc
39
khanhvinhdai1
K
ptm0412
  • Question Question
Lấy dữ liệu web nhiều trang về file Excel bằng Power Query
    • Thích
Trả lời
5
Đọc
2K
ptm0412
ptm0412
H
Công thức tìm kết quả
Trả lời
11
Đọc
123
VetMini
V
V
Hàm dò tìm lấy giá trị của lần xuất hiện thứ n trong excel.
Trả lời
9
Đọc
1K
VetMini
V
N
Nhờ các anh chỉ chỉnh lỗi giúp em với ạ, em cảm ơn ạ.
Trả lời
3
Đọc
82
minhminh27
minhminh27
T
File quản lý thiết bị trong trường học!
Trả lời
4
Đọc
138
VetMini
V
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
1
Đọc
126
VetMini
V
Momominh
Sơ đồ hàng hóa trong Container
Trả lời
3
Đọc
133
VetMini
V
hungtin1997
  • Question Question
[Hỏi] Tạo Hyperlink đến ô chạy ngang theo cột
Trả lời
6
Đọc
416
A HOANG 620
A
LuuAnh980
Add in tạo QR code miễn phí.
Trả lời
14
Đọc
566
htin1997
htin1997
tramcannt
Các bác cho hỏi làm cách nào để thu nhỏ thanh công thức này với ạ. Em cảm ơn.
Trả lời
2
Đọc
63
Nhattanktnn
Nhattanktnn
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom