Option Explicit
Sub AccImport()
Dim table As String
table = Sheet1.Cells(1, 1)
XoaCSDL
Dim acc As New Access.Application
acc.OpenCurrentDatabase "C:\Users\MyPC\Downloads\CSDL\CSDL.mdb", True, "1234"
acc.DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadSheetType:=acSpreadsheetTypeExcel12Xml, _
TableName:=table, _
Filename:=Application.ActiveWorkbook.FullName, _
HasFieldNames:=True, _
Range:="Sheet1$B4:r4000"
acc.CloseCurrentDatabase
acc.Quit
Set acc = Nothing
End Subcảm ơn bạn vậy mình chờ xem tin tốt lành từ bạn ...hay có bạn xyz nào tham gia một chút thì hay....
Ok Bạn 1 ý Tưởng rất hay
Giờ ta làm từng cái nhỏ 1 như vậy để cho các Bạn mới làm quen tham gia với cho nó vui ...và Gió nó mới lên được nha...
1/ Cách tạo một File CSDL.mdb áp dụng cho Office 2003 và cho 2010 To 2016
2/ Mình úp lên 1 file mẫu ta sẻ xử lý từ Excel trước khi lưu vào File CSDL
2.1/ Vùng dữ liệu lưu [A3:G25]
2.2/ Tổng hợp theo điều kiên [C4:C25] nếu có dữ liệu thì lưu vào CSDL
2.3/ Lưu dữ liệu nối xuống vào CSDL
.................
Thấy mới lạ tối qua tui keo chú Google tìm hoài link tinh ...cuối cùng lại thấy ngay trên GPE mà code dễ coi và hiểu hơn mấy trang nước ngoài + kế Toán khỉ ho gì gì đó
Uhm, Tham khảo bài viết của hai lúa. Mình đang sửa lại hàm ghi dữ liệu sử dụng SQL command xem có nhanh hơn không nhưng chưa được.Thấy mới lạ tối qua tui keo chú Google tìm hoài link tinh ...cuối cùng lại thấy ngay trên GPE mà code dễ coi và hiểu hơn mấy trang nước ngoài + kế Toán khỉ ho gì gì đó
http://www.giaiphapexcel.com/forum/...i-truy-vấn-CSDL-từ-file-Excel-đến-file-Access
Thiệt tìm chi xa xôi mệt chết .... Code GPE vẫn là Hàng 1 mà ....
...vắng vẻ quá ...
Ghi dữ liệu vào file khác hoạc sheet khác hoặc Access đều tương tự nhau. Quan trong là chuổi kết nối thôi.
Option Explicit
Function CheckExitTable(ByVal strField As String) As Boolean
'an Access object
Dim objAccess As Object
'connection string to access database
Dim strConnection As String
'catalog object
Dim objCatalog As Object
'connection object
Dim cnn As Object
Dim i As Integer
Dim intRow As Integer
Set objAccess = CreateObject("Access.Application")
'open access database
Call objAccess.OpenCurrentDatabase( _
"D:\Tai lieu co quan\PX15\PM CSCAK\GCSCAKNU.accdb")
'get the connection string
strConnection = objAccess.CurrentProject.Connection.ConnectionString
'close the access project
objAccess.Quit
'create a connection object
Set cnn = CreateObject("ADODB.Connection")
'assign the connnection string to the connection object
cnn.ConnectionString = strConnection
'open the adodb connection object
cnn.Open
'create a catalog object
Set objCatalog = CreateObject("ADOX.catalog")
'connect catalog object to database
objCatalog.ActiveConnection = cnn
'loop through the tables in the catalog object
intRow = 1
For i = 0 To objCatalog.Tables.Count - 1
'check if the table is a user defined table
If objCatalog.Tables.Item(i).Type = strField Then
'ckeck
strField = True
Exit Function
End If
Next i
strField = False
End Function
Sub test()
If CheckExitTable("2016") = False Then
MsgBox ("Field exists")
Else
MsgBox ("Field does not exist")
End If
End SubBạn thử qua link sau ngâm cứu truy vấn xem hay đó
http://www.giaiphapexcel.com/forum/...-lọc-từ-Excel-đến-CSDL-Access-bằn-ADO-căn-bản
Mình cũng đang từng bước nghiên cứu Access xem để tạo một cái Databace cho chương trình Quản lý bán Hàng của mình ....mà thấy nó khó quá hay sao thấy ít bài quá
Ít bạn nổi gió với nó quá ...thấy bài link trên rất hay nhưng ít người chơi quá ...
Sub AddData()
Dim Cn As ADODB.Connection
Set Cn = New ADODB.Connection
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=D:\Tai lieu co quan\PX15\PM CSCAK\Giai CSCA khoe13.xlsm;Extended Properties=Excel 8.0;" _
& "Persist Security Info=False"
Cn.Execute "INSERT INTO 2016 IN 'D:\Tai lieu co quan\PX15\PM CSCAK\GCSCAKNU.accdb' SELECT * FROM [DSNU$B5:P1000]"
Cn.Close
Set Cn = Nothing
End SubFunction 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 FunctionOption 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 SubWith 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 & "]"
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
atabase Password="""";" _atabase Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions" _on't Co" _
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ốiE 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
, _
"Jet OLEDB:Engine Type=5;Jet OLEDB
, _
"=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB
, _
"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ư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á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 ạ?
