Lỗi này là do khi lưu câu query lại khi mở ra editor của access tự chuyển dấu ( và ) thành [ và ], bạn xem lại hoặc có thể copy lại câu query tôi gửi trong bài #16 xem. Hoặc ngoài các cập dấu [] để bao tên trường, bạn thay hết thành cặp (), trước chứ AS T1 cũng bị thừa dấu ., bạn xóa cả dấu . này đi.
Theo mình bài toán này chắc là không dùng quẻy thông thường rồi mà phải là bài toán vòng lặp.
Option Compare Database
'Khai bao cac bien can dung
'Dim Connection As ADODB.Connection
Dim Connection As Object
Dim Command As ADODB.Command
Dim RecordSet1 As ADODB.Recordset
Dim RecordSet2 As ADODB.Recordset
Dim iNgay As Long, iNgayDi As Long, iNgayVe As Long
Dim fDate As Date, eDate As Date, i As Long, s As Long, SL As Long
Private Sub TinhToan()
'Khai bao cac bien can dung'
Dim strSQL As String
Dim MyConString As String
MyConString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = E:\Tam\OverAc\OverOne.mdb"
'Tao connection toi database'
Set Connection = New ADODB.Connection
Connection.Open MyConString
'Tao command làm viec voi database'
Set Command = New ADODB.Command
Command.ActiveConnection = Connection
'Xoa table Ketqua if true
Command.CommandText = "drop table KetQua"
On Error Resume Next
Command.Execute
'Xay dung SQL tao moi table KetQua gom co 2 field Ngay va soluong'
strSQL = "CREATE TABLE KetQua (Ngay date, Soluong integer)"
'Tao table KetQua'
Command.CommandText = strSQL
Command.Execute
'Tao recordset chua các data cua table Data'
Set RecordSet1 = New ADODB.Recordset
RecordSet1.Open "Data", Connection, adOpenStatic, adLockReadOnly, adCmdTable
'Tao recordset quan ly du lieu cua table KetQua'
Set RecordSet2 = New ADODB.Recordset
RecordSet2.Open "KetQua", Connection, adOpenKeyset, adLockOptimistic, adCmdTable
fDate = "03/01/2009"
eDate = "02/02/2009"
'Tao tung record cua table KetQua'
For i = CLng(fDate) To CLng(eDate)
iNgay = i
SL = 0
'Add ngay vao'
With RecordSet2
.AddNew
.Fields("Ngay").Value = CDate(iNgay)
End With
With RecordSet1
While Not .EOF
iNgayDi = CLng(.Fields("NgayDi").Value)
iNgayVe = CLng(.Fields("NgayVe").Value)
If iNgay >= iNgayDi Then
If iNgay <= iNgayVe Then
SL = SL + 1
End If
End If
'di chuyen den record ke'
.MoveNext
Wend
'di chuyen den record dau'
.MoveFirst
End With
RecordSet2.Fields("SoLuong").Value = SL
RecordSet2.Update
Next i
RecordSet1.Close: RecordSet2.Close: Connection.Close
Set Connection = Nothing: Set Command = Nothing
End Sub
Code của ThuNghi cũng tốt nhưng bị lệ thuộc vào Excel nhiều quá (Range, WorksheetFunction...)
Function GetWd(sDay, eDay)
Dim i As Long, j As Long, nD As Long, k As Long
Dim Dic1, Dic2, Arr(), sTmp, eTmp
On Error Resume Next
sTmp = sDay: eTmp = eDay
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
For i = LBound(sTmp, 1) To UBound(sTmp, 1)
For j = LBound(sTmp, 2) To UBound(sTmp, 2)
If sTmp(i, j) <> "" Then
For nD = sTmp(i, j) To eTmp(i, j)
If Not Dic1.Exists(nD) Then
k = k + 1
Dic1.Add nD, 1: Dic2.Add nD, k
ReDim Preserve Arr(1 To 2, 1 To k)
Arr(1, k) = nD: Arr(2, k) = 1
Else
Dic1.Item(nD) = Dic1.Item(nD) + 1
Arr(2, Dic2.Item(nD)) = Dic1.Item(nD)
End If
Next
End If
Next
Next
GetWd = Arr
End FunctionSub Main()
Dim sDay, eDay, res
sDay = Sheet2.Range("B2:B17")
eDay = Sheet2.Range("C2:C17")
res = GetWd(sDay, eDay)
Range("E2:F2").Resize(UBound(res, 2)) = WorksheetFunction.Transpose(res)
End SubSub ganStr()
fName = "E:\Tam\OverAc\OverTwo"
MyConString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source =" & fName & ".mdb"
End SubOption Compare Database
'Khai bao cac bien can dung
Dim Connection As Object
Dim Command As ADODB.Command
Dim RecordSet1 As ADODB.Recordset
Dim RecordSet2 As ADODB.Recordset
Dim iNgay As Long, iNgayDi As Long, iNgayVe As Long
Dim fDate As Date, eDate As Date, i As Long, j As Long, SL As Long
Dim strSQL As String, MyConString As String, fName As String
Dim Arr(), soRec As Long, soField As Long
Sub KetNoi()
Set Connection = New ADODB.Connection
Connection.Open MyConString
'Tao command làm viec voi database
Set Command = New ADODB.Command
Command.ActiveConnection = Connection
Set RecordSet1 = New ADODB.Recordset: Set RecordSet2 = New ADODB.Recordset
End Sub
Sub BoKetNoi()
Connection.Close: Set RecordSet1 = Nothing: Set RecordSet2 = Nothing
Set Connection = Nothing: Set Command = Nothing
End Sub
Sub ganStr()
fName = "E:\Tam\OverAc\OverTwo"
MyConString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source =" & fName & ".mdb"
End Sub
Private Sub TaoKQ()
ganStr
KetNoi
'Tao recordset chua các data cua table Data
RecordSet1.Open "Data", Connection, adOpenStatic, adLockReadOnly, adCmdTable
With RecordSet1
soRec = .RecordCount
soField = .Fields.Count
End With
ReDim Arr(1 To soRec, 1 To soField)
fDate = 0
With RecordSet1
While Not .EOF
For i = 1 To soRec
Arr(i, 1) = .Fields("NgayDi").Value
Arr(i, 2) = .Fields("NgayVe").Value
If fDate = 0 Or CLng(fDate) > CLng(Arr(i, 1)) Then fDate = Arr(i, 1)
If eDate < Arr(i, 2) Then eDate = Arr(i, 2)
.MoveNext
Next i
Wend
End With
TaoMDB
'Mo Recordset2
RecordSet2.Open "KetQua", Connection, adOpenKeyset, adLockOptimistic, adCmdTable
'Tao tung record cua table KetQua
For i = CLng(fDate) To CLng(eDate)
iNgay = i
SL = 0
For j = 1 To UBound(Arr)
If iNgay >= Arr(j, 1) Then
If iNgay <= Arr(j, 2) Then
SL = SL + 1
End If
End If
Next j
With RecordSet2
.AddNew
.Fields("Ngay").Value = CDate(iNgay)
.Fields("SoLuong").Value = SL
.Update
End With
Next i
BoKetNoi
Erase Arr
End Sub
Sub TaoMDB()
'Xoa va tao table Ketqua if true
Command.CommandText = "drop table KetQua"
On Error Resume Next
Command.Execute
'Xay dung SQL tao moi table KetQua gom co 2 field Ngay va soluong
strSQL = "CREATE TABLE KetQua (Ngay date, Soluong integer)"
'Tao table KetQua
Command.CommandText = strSQL
Command.Execute
End Sub
Bài này giải quyết đơn giản nếu có thêm 1 bảng có 1 field duy nhất có các record chạy từ 1 đến 31. Bình thử xem.
Giả dụ có 1 table như vậy thì Kiệt sẽ làm thế nào.
Nếu có bảng như vậy thì hoàn toàn giải quyết bằng query được bác ạ.
Trong acc có thể tạo 1 query tạo 1 table có ngày là fDate (cho trước) đến eDate (cho trước), mỗi ngày 1 record?
Mới hỏi Bác Mỹ và có cách rồi
Nhưng nếu tham chiếu tới Acc thì
Excel 8.0 phải thay là gì
