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:
