Mình không nghỉ như vậy.kellyfe đã viết:
Bạn cứ việc post lên diễn đàn sẽ có người "chung tay".
Chào bạn Kellyfe,kellyfe đã viết:
Nếu bạn không thể post bài thì gởi cho tôi, tôi sẽ giúp bạn đưa lên.
Bạn nên đưa ra bài toán cụ thể của bạn, mọi người sẽ trợ giúp. Và chú ý: viết tiếng việt có dấu.
Option Explicit
'Constant for Database connection string'
Private Const glob_DBPath = "C:\Temp\Examples.mdb"
Private Const glob_sConnect = _
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & glob_DBPath & ";"
Private Sub RetrieveRecordset(strSQL As String, clTrgt As Range)
'Author : Ken Puls ([URL="http://www.excelguru.ca/"]www.excelguru.ca[/URL])'
'Macro Purpose: To retrieve a recordset from a database (via an SQL query) and place'
' it in the supplied worksheet range'
'NOTE : Requires a reference to "Microsoft ActiveX Data Objects 2.x Library"'
' (Developed with reference to version 2.0 of the above)'
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim rcArray As Variant
Dim lFields As Long
Dim lRecrds As Long
Dim lCol As Long
Dim lRow As Long
'Open connection to the database'
cnt.Open glob_sConnect
'Open recordset based on Orders table'
rst.Open strSQL, cnt
'Count the number of fields to place in the worksheet'
lFields = rst.Fields.Count
'Check version of Excel'
If Val(Mid(Application.Version, 1, InStr(1, Application.Version, ".") - 1)) > 8 Then
'EXCEL 2000 or 2002: Use CopyFromRecordset'
'Copy the recordset from the database'
On Error Resume Next
clTrgt.CopyFromRecordset rst
'CopyFromRecordset will fail if the recordset contains an OLE'
'object field or array data such as hierarchical recordsets'
If Err.Number <> 0 Then GoTo EarlyExit
Else
'EXCEL 97 or earlier: Use GetRows then copy array to Excel'
'Copy recordset to an array'
rcArray = rst.GetRows
'Determine number of records (adds 1 since 0 based array)'
lRecrds = UBound(rcArray, 2) + 1
'Check the array for contents that are not valid when'
'copying the array to an Excel worksheet'
For lCol = 0 To lFields - 1
For lRow = 0 To lRecrds - 1
'Take care of Date fields'
If IsDate(rcArray(lCol, lRow)) Then
rcArray(lCol, lRow) = Format(rcArray(lCol, lRow))
'Take care of OLE object fields or array fields'
ElseIf IsArray(rcArray(lCol, lRow)) Then
rcArray(lCol, lRow) = "Array Field"
End If
Next lRow
Next lCol
'Transpose and place the array in the worksheet'
clTrgt.Resize(lRecrds, lFields).Value = TransposeDim(rcArray)
End If
EarlyExit:
'Close and release the ADO objects'
rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing
On Error GoTo 0
End Sub[B]Private Function TransposeDim(v As Variant) As Variant[/B]
'Function Purpose: Transpose a 0-based array (v)'
Dim x As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For x = 0 To Xupper
For Y = 0 To Yupper
tempArray(x, Y) = v(Y, x)
Next Y
Next x
TransposeDim = tempArray
[B]End Function[/B]Sub GetRecords()
'Macro Purpose: To retrieve a recordset to an Excel worksheet'
Dim sSQLQry As String
Dim rngTarget As Range
'Generate the SQL query and set the range to place the data in'
sSQLQry = "SELECT tblMoorages.CustID, tblMoorages.Type, " & _
"tblMoorages.DatePaid, tblMoorages.Amount FROM tblMoorages;"
ActiveSheet.Cells.ClearContents
Set rngTarget = ActiveSheet.Range("A2")
'Retrieve the records'
Call RetrieveRecordset(sSQLQry, rngTarget)
End SubSub DB_Insert_via_ADOSQL()
'Author : Ken Puls ([URL="http://www.excelguru.ca/"]www.excelguru.ca[/URL])
'Macro purpose: To add record to Access database using ADO and SQL
'NOTE: Reference to Microsoft ActiveX Data Objects Libary required
Dim cnt As New ADODB.Connection, _
rst As New ADODB.Recordset, _
dbPath As String, _
tblName As String, _
rngColHeads As Range, _
rngTblRcds As Range, _
colHead As String, _
rcdDetail As String, _
ch As Integer, _
cl As Integer, _
notNull As Boolean
'Set the string to the path of your database as defined on the worksheet
dbPath = ActiveSheet.Range("B1").Value
tblName = ActiveSheet.Range("B2").Value
Set rngColHeads = ActiveSheet.Range("tblHeadings")
Set rngTblRcds = ActiveSheet.Range("tblRecords")
'Concatenate a string with the names of the column headings
colHead = " ("
For ch = 1 To rngColHeads.Count
colHead = colHead & rngColHeads.Columns(ch).Value
Select Case ch
Case Is = rngColHeads.Count
colHead = colHead & ")"
Case Else
colHead = colHead & ","
End Select
Next ch
'Open connection to the database
cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & dbPath & ";"
'Begin transaction processing
On Error GoTo EndUpdate
cnt.BeginTrans
'Insert records into database from worksheet table
For cl = 1 To rngTblRcds.Rows.Count
'Assume record is completely Null, and open record string for concatenation
notNull = False
rcdDetail = "('"
'Evaluate field in the record
For ch = 1 To rngColHeads.Count
Select Case rngTblRcds.Rows(cl).Columns(ch).Value
'if empty, append value of null to string
Case Is = Empty
Select Case ch
Case Is = rngColHeads.Count
rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & "NULL)"
Case Else
rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & "NULL,'"
End Select
'if not empty, set notNull to true, and append value to string
Case Else
notNull = True
Select Case ch
Case Is = rngColHeads.Count
rcdDetail = rcdDetail & rngTblRcds.Rows(cl).Columns(ch).Value & "')"
Case Else
rcdDetail = rcdDetail & rngTblRcds.Rows(cl).Columns(ch).Value & "','"
End Select
End Select
Next ch
'If record consists of only Null values, do not insert it to table, otherwise
'insert the record
Select Case notNull
Case Is = True
rst.Open "INSERT INTO " & tblName & colHead & " VALUES " & rcdDetail, cnt
Case Is = False
'do not insert record
End Select
Next cl
EndUpdate:
'Check if error was encounted
If Err.Number <> 0 Then
'Error encountered. Rollback transaction and inform user
On Error Resume Next
cnt.RollbackTrans
MsgBox "There was an error. Update was not succesful!", vbCritical, "Error!"
Else
On Error Resume Next
cnt.CommitTrans
End If
'Close the ADO objects
cnt.Close
Set rst = Nothing
Set cnt = Nothing
On Error GoTo 0
End Sub
ThuNghi đã viết:
Theo tôi nếu chỉ đơn giản như thế thì Excel dùng vô tư. Tôi cũng đã làm công việc như bạn với # 1000 style, mỗi style # 4 NL.BinhTam đã viết:
BinhTam đã viết:
Cám ơn ngocmai, BinhTam đã liên hệ với tôi trước rồi:ngocmaipretty đã viết:
Chúc BinhTam tiến bộ sau các bài của NgocmaiprettyBinhTam đã viết:
TuanVNUNI đã viết:
BinhTam đã viết:
Private Sub Command0_Click()
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel11, "details", "d:\p2.xls", , "tkn!A:A"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel11, "import", "d:\p2.xls", , "tkn!K:K"
End SubPrivate Sub Command6_Click()
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel11, "tkxde", "d:\p2.xls", , "tkx!a:a"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel11, "tkx", "d:\p2.xls", , "tkx!k:k"
End SubSub clearxls()
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
Const conMAX_ROWS = 20000
Dim conSHT_NAME(1 To 2) As String
conSHT_NAME(1) = "tkn"
conSHT_NAME(2) = "tkx"
Const conWKB_NAME = "d:\p2.xls"
Set objXL = New Excel.Application
With objXL
Set objWkb = .Workbooks.Open(conWKB_NAME)
For i = 1 To 2
Set objSht = objWkb.Worksheets(conSHT_NAME(i))
intLastCol = objSht.UsedRange.Columns.Count
With objSht
.Range(.Cells(1, 1), .Cells(conMAX_ROWS, _
intLastCol + 10)).Clear
End With
Next
End With
objXL.Workbooks.Close
objXL.Application.Quit
Set objSht = Nothing
Set objWkb = Nothing
Set objXL = Nothing
End Sub
Run-time error '-2147217900 (80040e14)
[Microsoft][ODBC Microsoft Access Driver] Syntax error in INSERT INTO statement.TargetDetail.Open "INSERT INTO " & tblName & colHead & " VALUES " & rcdDetail, gcnAccess'Cách 1:
Function InsertInto_GLDATA()
'Macro purpose: To add record to Access database using ADO and SQL
'NOTE: Reference to Microsoft ActiveX Data Objects Libary required
'-------------------------------------------------------------------------------
Application.ScreenUpdating = False
Dim gcnAccess as New ADOB.connection
Dim gcnRecords as New ADOB.Recordset
Dim rngDetail As Range
Dim tblName As String
tblName = "GLDATA"
'-------------------------------------------------------------------------------
'Open connection to the database
Call ConnectToDatabase
'Chuan bi tien hanh import du lieu vao access
On Error GoTo EndUpdate
'-------------------------------------------------------------------------------
'Insert records into database from worksheet table
gcnAccess.BeginTrans
Set gcnRecords = New ADODB.recordset
For Each rngDetail In Range(Sheets("GLDATA").[a2], Sheets("GLDATA").[a65536].End(xlUp))
gcnRecords.Open "Select Period,DocNbr,DocDate,DocDesc,DocAttached,DrAcct,CrAcct,CustVendID,InvtID,LineQty," & _
"LineUP,LineAmt,Serial,InvcNbr,InvcDate,TaxRate,InvcDesc,ContactName,WorkCode,TaxID," & _
"Division,CostCenter,CflwID,User,Date From " & tblName, gcnAccess, adOpenStatic, adLockPessimistic, adCmdText
With gcnRecords
.AddNew ' create a new record
' Add values to each field in the record
.Fields("Period") = rngDetail.Value
.Fields("DocNbr") = rngDetail(, 2).Value
.Fields("DocDate") = rngDetail(, 3).Value
.Fields("DocDesc") = rngDetail(, 4).Value
.Fields("DocAttached") = rngDetail(, 5).Value
.Fields("DrAcct") = rngDetail(, 6).Value
.Fields("CrAcct") = rngDetail(, 7).Value
.Fields("CustVendID") = rngDetail(, 8).Value
.Fields("InvtID") = rngDetail(, 9).Value
.Fields("LineQty") = rngDetail(, 10).Value
.Fields("LineUP") = rngDetail(, 11).Value
.Fields("LineAmt") = rngDetail(, 12).Value
.Fields("Serial") = rngDetail(, 13).Value
.Fields("InvcNbr") = rngDetail(, 14).Value
.Fields("InvcDate") = rngDetail(, 15).Value
.Fields("TaxRate") = rngDetail(, 16).Value
.Fields("InvcDesc") = rngDetail(, 17).Value
.Fields("ContactName") = rngDetail(, 18).Value
.Fields("WorkCode") = rngDetail(, 19).Value
.Fields("TaxID") = rngDetail(, 20).Value
.Fields("Division") = rngDetail(, 21).Value
.Fields("CostCenter") = rngDetail(, 22).Value
.Fields("CflwID") = rngDetail(, 23).Value
.Fields("User") = rngDetail(, 24).Value
.Fields("Date") = rngDetail(, 25).Value
.Update ' stores the new record
.Close
End With
Next
a = MsgBox("Da cap nhat du lieu vao he thong thanh cong!", vbInformation, "Thong bao")
'-------------------------------------------------------------------------------------------------
EndUpdate:
'Check if error was encounted
If Err.Number <> 0 Then
'Error encountered. Rollback transaction and inform user
On Error Resume Next
gcnAccess.RollbackTrans
MsgBox vbObjectError & "-" & Err.Number & "-" & Err.Description, vbCritical, "Error!"
Else
On Error Resume Next
gcnAccess.CommitTrans
End If
'Close the ADO objects
gcnAccess.Close
Set gcnRecords = Nothing
Set gcnAccess = Nothing
On Error GoTo 0
Application.ScreenUpdating = True
End Function'Cách 2:
Function InsertInto_GLDATA()
'Macro purpose: To add record to Access database using ADO and SQL
'NOTE: Reference to Microsoft ActiveX Data Objects Libary required
'-------------------------------------------------------------------------------
Dim colHead, rcdDetail As String
Dim rngHeader, rngDetail As Range
Dim NColumn As Integer
Dim NRow As Integer
Dim NotNull As Boolean
Dim tblName As String
Dim TargetDetail As New ADODB.recordset
Set rngHeader = Range("A1:Y1")
Set rngDetail = Range("A2:Y2")
tblName = "GLDATA"
'MsgBox rngDetail.Address & Chr(13) & rngHeader.Address, , "Thong bao"
'Truyen tham so cot can insert vao access:
'Ke noi chuoi cac cot trong cu pham Insert into tblTemp(column1, column2,column3,....)
colHead = " ("
For NColumn = 1 To rngHeader.Count
colHead = colHead & rngHeader.Columns(NColumn).Value
Select Case NColumn
Case Is = rngHeader.Count
colHead = colHead & ")"
Case Else
colHead = colHead & ","
End Select
Next NColumn
MsgBox "Insert into " & colHead & " From " & tblName, , "Thong bao" 'kietvt: Bay loi tai day
'-------------------------------------------------------------------------------
'Open connection to the database
Call ConnectToDatabase
'Chuan bi tien hanh import du lieu vao access
On Error GoTo EndUpdate
'-------------------------------------------------------------------------------
'Insert records into database from worksheet table
gcnAccess.BeginTrans
For NRow = 1 To rngDetail.Rows.Count
'Assume record is completely Null, and open record string for concatenation
NotNull = False
rcdDetail = "('"
'Evaluate field in the record
For NColumn = 1 To rngHeader.Count
Select Case rngDetail.Rows(NRow).Columns(NColumn).Value
'if empty, append value of null to string
Case Is = Empty
Select Case NColumn
Case Is = rngHeader.Count
rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & "'')" 'Neu gia tri null thi bo qua va cach nhau boi dau ")" trong truong hop cot cuoi cung
Case Else
rcdDetail = Left(rcdDetail, Len(rcdDetail) - 1) & ",'" 'Neu gia tri null thi bo qua va cach nhau boi dau ")" trong truong hop cot cuoi cung
End Select
'if not empty, set notNull to true, and append value to string
Case Else
NotNull = True
Select Case NColumn
Case Is = rngHeader.Count
rcdDetail = rcdDetail & rngDetail.Rows(NRow).Columns(NColumn).Value & "')"
Case Else
rcdDetail = rcdDetail & rngDetail.Rows(NRow).Columns(NColumn).Value & "','"
End Select
End Select
Next NColumn
MsgBox rcdDetail, , "Thongbao" 'kiet
'If record consists of only Null values, do not insert it to table, otherwise
'insert the record
Select Case NotNull
Case Is = True
TargetDetail.Open "INSERT INTO " & tblName & colHead & " VALUES " & rcdDetail, gcnAccess
Case Is = False
'do not insert record
End Select
Next NRow
a = MsgBox("Da cap nhat du lieu vao he thong thanh cong!", vbInformation, "Thong bao")
EndUpdate:
'Check if error was encounted
If Err.Number <> 0 Then
'Error encountered. Rollback transaction and inform user
On Error Resume Next
gcnAccess.RollbackTrans
MsgBox vbObjectError & "-" & Err.Number & "-" & Err.Description, vbCritical, "Error!"
Else
On Error Resume Next
gcnAccess.CommitTrans
End If
'Close the ADO objects
gcnAccess.Close
Set TargetData = Nothing
Set gcnAccess = Nothing
On Error GoTo 0
End Function
Dim dtbAc As Database
Dim strTen As String
Set strTen = "D\BaiTap\Data.mdb"
Set dtbAc = DBEngine.Workspaces(0).OpenDatabase(strTen)SELECT tblPhieuThuChi.RecKey, tblPhieuThuChi.Ngay, tblPhieuThuChi.SoCT, tblPhieuThuChi.LoaiCT, tblPhieuThuChi.DienGiai, tblPhieuChiTiet.TKDU, tblPhieuChiTiet.SoTien
FROM tblPhieuThuChi INNER JOIN tblPhieuChiTiet ON tblPhieuThuChi.RecKey = tblPhieuChiTiet.RecKey
WHERE (((tblPhieuThuChi.Ngay)<[TuNgay]));SELECT tblPhieuThuChi.RecKey, tblPhieuThuChi.Ngay, tblPhieuThuChi.SoCT, tblPhieuThuChi.LoaiCT, tblPhieuThuChi.DienGiai, tblPhieuChiTiet.TKDU, tblPhieuChiTiet.SoTien
FROM tblPhieuThuChi INNER JOIN tblPhieuChiTiet ON tblPhieuThuChi.RecKey = tblPhieuChiTiet.RecKey
WHERE (((tblPhieuThuChi.Ngay) Between [TuNgay] And [DenNgay]));Function XoaTab(TabName As String)
Dim TenFile As String
TenFile = "D:\BaiTap\Data.mdb"
Dim Tien As Database
Set Tien = DBEngine.Workspaces(0).OpenDatabase(TenFile)
Dim ThisTab As Recordset
Set ThisTab = Tien.OpenRecordset(TabName, dbOpenTable)
If ThisTab.RecordCount > 0 Then
ThisTab.MoveFirst
Do Until ThisTab.EOF
ThisTab.Delete
ThisTab.MoveNext
Loop
End If
End FunctionFunction TinhTonDau(TruocNgay)
Dim TenFile As String
Dim Tien As Database
Dim NK As Recordset
Dim Ton As Recordset
Dim QNK As QueryDef
TenFile = "D:\BaiTap\Data.mdb"
Set Tien = DBEngine.Workspaces(0).OpenDatabase(TenFile)
Set QNK = Tien.QueryDefs("qryChiTietTruoc")
QNK.Parameters("TuNgay") = TruocNgay
Set NK = QNK.OpenRecordset()
Set Ton = Tien.OpenRecordset("tblTonDau", dbOpenTable)
On Error Resume Next
If Ton.RecordCount > 0 Then Call XoaTab("tblTonDau")
TonDK = 0
If NK.RecordCount > 0 Then
NK.MoveFirst
Do Until NK.EOF
If NK!LoaiCT = "PT" Then
TonDK = TonDK + NK!SoTien
Else
TonDK = TonDK - NK!SoTien
End If
NK.MoveNext
Loop
End If
Ton.AddNew
Ton!TonDau = TonDK
Ton.Update
Ton.Close: Set Tien = Nothing
End FunctionFunction SoQuy(TuNgay, DenNgay)
Dim TenFile As String
Dim Tien As Database
Dim NKTC As Recordset
Dim NK As Recordset
Dim QNK As QueryDef
TenFile = "D:\BaiTap\Data.mdb"
Set Tien = DBEngine.Workspaces(0).OpenDatabase(TenFile)
Set QNK = Tien.QueryDefs("qryChiTietTrong")
QNK.Parameters("TuNgay") = TuNgay
QNK.Parameters("DenNgay") = DenNgay
Set NKTC = QNK.OpenRecordset()
Set NK = Tien.OpenRecordset("tblChiTiet", dbOpenTable)
On Error Resume Next
If NK.RecordCount > 0 Then Call XoaTab("tblChiTiet")
If NKTC.RecordCount > 0 Then
NKTC.MoveFirst
Do Until NKTC.EOF
NK.AddNew
NK!Ngay = NKTC!Ngay
NK!SoCT = NKTC!SoCT
NK!LoaiCT = NKTC!LoaiCT
NK!DienGiai = NKTC!DienGiai
NK!TKDU = NKTC!TKDU
NK!SoTien = NKTC!SoTien
NK.Update
NKTC.MoveNext
Loop
End If
NK.Close: NKTC.Close: Set Tien = Nothing
End FunctionFunction MoFileEx(ExTaiLieu As String)
Dim ExTen As String
Dim Ex As Workbook
ExTen = TimFile(ExTaiLieu)
Set Ex = GetObject(ExTaiLieu)
Ex.Application.Windows(ExTen).Visible = True
Set Ex = Nothing
End FunctionFunction TimFile(TenFile As String)
Dim n As Integer
For n = Len(TenFile) To 1 Step -1
ViTri = Mid(TenFile, n, 1)
If ViTri = "\" Then
Exit For
End If
Next
TimFile = Right(TenFile, Len(TenFile) - n)
End FunctionFunction LocSoQuy()
Dim TenFile As String
Dim Tien As Database
Dim NK As Recordset
Dim Ton As Recordset
TenFile = "D:\BaiTap\Data.mdb"
Set Tien = DBEngine.Workspaces(0).OpenDatabase(TenFile)
Set NK = Tien.OpenRecordset("tblChiTiet", dbOpenTable)
Set Ton = Tien.OpenRecordset("tblTondau", dbOpenTable)
Dim SoQuy As String
SoQuy = "D:\Luu\So Quy Tien Mat.xls"
Call MoFileEx(SoQuy) ‘ Mở File Excel mẫu
Cells(2, 4) = S00.NgayDau ‘ Lấy giá trị NgayDau đặt vào ô D2
Cells(3, 4) = S00.NgayCuoi ‘ Lấy giá trị NgayCuoi đặt vào ô D3
If Ton.RecordCount > 0 Then
Cells(3, 6) = Ton!TonDau ‘ Lấy giá trị Tồn Đầu Kỳ đa75t vào ô F3
End If
If NK.RecordCount > 0 Then
NK.MoveFirst
Dim m As Long, n As Long ‘ Lấy giá trị phát sinh đặt vào ô tương ứng
For m = 1 To NK.RecordCount
n = Range("F5000").End(xlUp).Row
Cells(n + 1, 1) = NK!Ngay
Cells(n + 1, 2) = NK!SoCT
Cells(n + 1, 3) = NK!LoaiCT
Cells(n + 1, 4) = NK!DienGiai
Cells(n + 1, 5) = NK!TKDU
If NK!LoaiCT = "PT" Then
Cells(n + 1, 6) = NK!SoTien
Cells(n + 1, 7) = 0
Else
Cells(n + 1, 7) = NK!SoTien
Cells(n + 1, 6) = 0
End If
NK.MoveNext
Next
End If
Call FormatDongSoQuy
NK.Close: Ton.Close: Set Tien = Nothing
End FunctionSub Loc_Click()
Application.ScreenUpdating = False
TuNgay = S00.NgayDau.Value
DenNgay = S00.NgayCuoi.Value
Call TinhTonDau(TuNgay)
Call SoQuy(TuNgay, DenNgay)
Call LocSoQuy
Application.ScreenUpdating = True
End SubFunction FormatDongSoQuy()
‘ Kẻ dòng
Range("A6:G" & Range("G1000").End(xlUp).Row).Select
With Selection
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
If Range("G1000").End(xlUp).Row > 6 Then
.Borders(xlInsideHorizontal).LineStyle = xlDot
End If
End With
Range("A" & Range("G1000").End(xlUp).Row + 1 & ":E" & Range("G1000").End(xlUp).Row + 2).Select
With Selection
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
Range("F" & Range("G1000").End(xlUp).Row + 1 & ":G" & Range("G1000").End(xlUp).Row + 2).Select
With Selection
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
‘ Tính tổng Thu
Range("F" & Range("G1000").End(xlUp).Row + 1).Select
ActiveCell.Value = Application.WorksheetFunction.Sum(Range("F6:F" & Range("G1000").End(xlUp).Row))
ActiveCell.Font.Bold = True
ActiveCell.NumberFormat = "#,##0"
‘Tính tổng Chi
Range("G" & Range("G1000").End(xlUp).Row + 1).Select
ActiveCell.Value = Application.WorksheetFunction.Sum(Range("G6:G" & Range("G1000").End(xlUp).Row))
ActiveCell.Font.Bold = True
ActiveCell.NumberFormat = "#,##0"
‘Ghi chữ Cộng ở dòng Tổng Phát Sinh
Range("D" & Range("G1000").End(xlUp).Row).Select
ActiveCell.Value = S00.Cells(5, 1) ‘ Chữ Cộng ở ô A5
ActiveCell.Font.Bold = True
ActiveCell.HorizontalAlignment = xlRight
‘Tính tồn cuối kỳ
Range("F" & Range("F1000").End(xlUp).Row + 1).Select
ActiveCell.FormulaR1C1 = "=R3C6+R" & Range("F1000").End(xlUp).Row & "C6-R" & Range("G1000").End(xlUp).Row & "C7"
ActiveCell.Font.Bold = True
ActiveCell.NumberFormat = "#,##0"
Range("D" & Range("F1000").End(xlUp).Row).Select
ActiveCell.Value = S00.Cells(6, 1) ‘ Chữ Tồn Quỹ Cuối Kỳ ở ô A6
ActiveCell.Font.Bold = True
ActiveCell.HorizontalAlignment = xlRight
End FunctionSELECT tblPhieuThuChi.RecKey, tblPhieuThuChi.Ngay, tblPhieuThuChi.SoCT, tblPhieuThuChi.LoaiCT, tblPhieuThuChi.DienGiai, tblPhieuChiTiet.TKDU, tblPhieuChiTiet.SoTien[font=Verdana]FROM tblPhieuThuChi INNER JOIN tblPhieuChiTiet ON tblPhieuThuChi.RecKey = tblPhieuChiTiet.RecKey[/font]
[font=Verdana]WHERE (((tblPhieuThuChi.Ngay)<[TuNgay]));[/font]SELECT tblPhieuThuChi.RecKey, tblPhieuThuChi.Ngay, tblPhieuThuChi.SoCT, tblPhieuThuChi.LoaiCT, tblPhieuThuChi.DienGiai, tblPhieuChiTiet.TKDU, tblPhieuChiTiet.SoTien[font=Verdana]FROM tblPhieuThuChi INNER JOIN tblPhieuChiTiet ON tblPhieuThuChi.RecKey = tblPhieuChiTiet.RecKey[/font]
[font=Verdana]WHERE (((tblPhieuThuChi.Ngay) Between [TuNgay] And [DenNgay]));[/font][B]Function[/B] FormatDongSoQuy()Select, ActiveCellFunction IsInternational(strCountry As String) As String
If strCountry = "USA" Then
IsInternational = "Local"
Else
IsInternational = "Intl"
End If
End FunctionSub xlTest()
Dim db As Database
rs1 As Recordset
Dim qry As QueryDef
Set db = Workspaces(0).OpenDatabase _
("C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb")
[COLOR="Blue"] ' Replace the above path with the correct path to the _
' sample Northwind.mdb database on your computer. [/COLOR]
Set qry = db.QueryDefs("qryExcelTest")
Set rs1 = qry.OpenRecordset
rs1.MoveLast
rs1.Close
db.Close
End Subrun-time error '3085'
undefined function 'IsInternational' in expressionsSQL = "SELECT * " & _
"FROM Q_Count_Extra_P001; "Set adoResSap = QueryRecords(gcnAccess, sSQLSap)Sub SimpleCmd3()
Dim Cmd As New ADODB.Command
Dim RS As New ADODB.Recordset
Cmd.ActiveConnection = FileDS
Cmd.CommandText = "CustomerCount" [b]'Có thể là tên của table, view hay [COLOR="Red"]query[/COLOR] [/b]
Cmd.Execute
RS.Open Cmd
MsgBox RS(0)
End SubSub xlTest()
Dim AC As Access.Application
Set AC = New Access.Application
AC.OpenCurrentDatabase "C:\Program Files\Microsoft _
Office\Office\Samples\Northwind.mdb" , False, False
Dim db As Database
rs1 As Recordset
Dim qry As QueryDef
Set db = AC.DBEngine.Workspaces(0).OpenDatabase _
("C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb")
[COLOR=Blue] ' Replace the above path with the correct path to the _
' sample Northwind.mdb database on your computer. [/COLOR]
Set qry = db.QueryDefs("qryExcelTest")
Set rs1 = qry.OpenRecordset
rs1.MoveLast
rs1.Close
db.Close
AC.CloseCurrentDatabase
End Sub
Thì bạn tạo 1 form trong đó bạn tạo 1 nút command button sau đó tạo 1 macro với action là OutputTo trong Obejecttype bạn chọn query, Object name bạn chọn query cần mở. Phần Output Format bạn chọn Ms Excel97-2003. Phần Auto start chọn Yes.Lưu macro lại. Chạy
Option Compare Database
Const cnn = "Provider = Microsoft.ACE.OLEDB.12.0;" & "Data Source=C:\Documents and Settings\Administrator\Desktop\ket noi\test1.xlsx;" & "Extended Properties = Excel 12.0"
Sub get_Edata()
Dim myCn As String, mySql As String
Dim myRc As ADODB.Recordset
Dim myTb As ADODB.Recordset
myCn = cnn
mySql = "select*from[sheet1$]"
Set myRc = New ADODB.Recordset
myRc.Open mySql, myCn, adOpenStatic, adLockReadOnly
Set myTb = New ADODB.Recordset
myTb.Open "tbldulieu", CurrentProject.Connection, adOpenDynamic, adLockOptimistic, adCmdTable
Do Until myRc.EOF
myTb.AddNew
myTb!ID = myRc!ID
myTb!maKH = myRc!maKH
myTb!TenKH = myRc!TenKH
myTb!Diachi = myRc!Diachi
myTb!Dienthoai = myRc!Dienthoai
myTb!Congty = myRc!Congty
myTb!DienthoaiCT = myRc!DienthoaiCT
myTb!Mahang = myRc!Mahang
myTb!Soluong = myRc!Soluong
myTb!Dongia = myRc!Dongia
myTb!Thanhtien = myRc!Thanhtien
myTb!MaNV = myRc!MaNV
myTb!Mavung = myRc!Mavung
myTb!Sohoadon = myRc!Sohoadon
myTb.Update
myRc.MoveNext
Loop
End Sub
.
Option Compare Database
Const cnn = "Provider = Microsoft.ACE.OLEDB.12.0;" & "Data Source=C:\Documents and Settings\Administrator\Desktop\ket noi\test1.xlsx;" & "Extended Properties = Excel 12.0"
Sub get_Edata()
Dim myCn As String
Dim myRc As ADODB.Recordset
Dim myTb As ADODB.Recordset
Dim mySql As String
myCn = cnn
mySql = "select*from[sheet1$]"
Set myRc = New ADODB.Recordset
myRc.Open mySql, myCn, adOpenStatic, adLockReadOnly
Set myTb = New ADODB.Recordset
myTb.Open "tbldulieu", CurrentProject.Connection, adOpenDynamic, adLockOptimistic, adCmdTable
Do Until myRc.EOF
myTb.AddNew
myTb!ID = myRc!ID
myTb!maKH = myRc!maKH
myTb!TenKH = myRc!TenKH
myTb!Diachi = myRc!Diachi
myTb!Dienthoai = myRc!Dienthoai
myTb!Congty = myRc!Congty
myTb!DienthoaiCT = myRc!DienthoaiCT
myTb!Mahang = myRc!Mahang
myTb!Soluong = myRc!Soluong
myTb!Dongia = myRc!Dongia
myTb!Thanhtien = myRc!Thanhtien
myTb!MaNV = myRc!MaNV
myTb!Mavung = myRc!Mavung
myTb!Sohoadon = myRc!Sohoadon
myTb.Update
myRc.MoveNext
Loop
End Sub
em dùng đoạn code (học được từ diễn đàn) này để cập nhật dữ liệu từ excel vào access, khi chạy chương trình không báo lỗi nhưng dữ liệu không cập nhật vào bảng tbldulieu được.
Các bác chỉ giúp em sai ở chỗ nào với ạ
Thanks
Const cnn = "Provider= Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=C:\Documents and Settings\Administrator\Desktop\ket noi\test1.xlsx;" & _
"Extended Properties=Excel 12.0"
Private Sub Command0_Click()
Dim strPathFile As String, strFile As String, strPath As String
Dim strTable As String
Dim blnHasFieldNames As Boolean
blnHasFieldNames = True
strPath = "C:\Le Phat Dom\STUDY\ACCESS\" [COLOR=darkgreen]'Đường dẫn đến file Excel của bạn[/COLOR]
strTable = "tbldulieu"
strFile = Dir(strPath & "*.xls")
Do While Len(strFile) > 0
strPathFile = strPath & strFile
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames, "SHEET1!"
strFile = Dir()
Loop
MsgBox "Da nhap xong du lieu ", vbExclamation, "Nhap du lieu tu Excel"
End SubBạn copy vùng ở sheet1 thì sửa lại như sau:
[COLOR=red]'....[/COLOR]
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames, "SHEET1![COLOR=red][B]A1:B200[/B][/COLOR]" 'Ở đây giả sử tôi copy vùng [B][COLOR=#ff0000]A1:B200 ở Sheet1[/COLOR][/B]
[COLOR=red]'....[/COLOR]File mình gửi không có thiết lập gì nhiều chỉ tạo nút bấm, các thuộc tính trên form, nhưng nó không ảnh hưởng gì đến code, nó chỉ làm cho đẹp thôi.
Như mình đã nói ở bài số #7 vấn đề đau đầu là ID với các mối quan hệ trong bảng, tùy trường hợp mình khắc phục thôi.
Cho mình hỏi thêm là bạn nhập dữ liệu lần 2 vào bằng cách nào vậy bạn ?
