5
Tôi đang cố gắng sử dụng Excel làm Cơ sở dữ liệu và tôi đang làm theo hướng dẫn từ this site.Lỗi OLE khi chạy VBA trong Excel 2016?
Vấn đề là, bất cứ khi nào tôi cố gắng "Cập nhật Drop Downs" trong tệp dưới đây, tôi nhận được lỗi này: "Microsoft đang chờ một ứng dụng khác hoàn thành một hành động OEL".
Tôi đang thiếu gì hoặc làm sai ở đây và làm thế nào để tôi nhận được quyền này?
Tôi đang sử dụng Excel 2016 Home & Học sinh đang phát triển. Tôi cũng cho phép Macros khi mở Workbook.
Cùng một tệp chạy hoàn hảo khi mở trong Excel 2007. Tôi cũng nhận thấy rằng Microsoft ActiveX Data Objects 6.0 Library tham chiếu đến "msado60.dll" trong ví dụ, trong khi đó, tệp "msado60.tlb" trong Excel 2016 (mà tôi sử dụng).
Private Sub cmdShowData_Click()
'populate data
strSQL = "SELECT * FROM [data$] WHERE "
If cmbProducts.Text <> "" Then
strSQL = strSQL & " [Product]='" & cmbProducts.Text & "'"
End If
If cmbRegion.Text <> "" Then
If cmbProducts.Text <> "" Then
strSQL = strSQL & " AND [Region]='" & cmbRegion.Text & "'"
Else
strSQL = strSQL & " [Region]='" & cmbRegion.Text & "'"
End If
End If
If cmbCustomerType.Text <> "" Then
If cmbProducts.Text <> "" Or cmbRegion.Text <> "" Then
strSQL = strSQL & " AND [Customer Type]='" & cmbCustomerType.Text & "'"
Else
strSQL = strSQL & " [Customer Type]='" & cmbCustomerType.Text & "'"
End If
End If
If cmbProducts.Text <> "" Or cmbRegion.Text <> "" Or cmbCustomerType.Text <> "" Then
'now extract data
closeRS
OpenDB
rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Sheets("View").Visible = True
Sheets("View").Select
Range("dataSet").Select
Range(Selection, Selection.End(xlDown)).ClearContents
'Now putting the data on the sheet
ActiveCell.CopyFromRecordset rs
Else
MsgBox "I was not able to find any matching records.", vbExclamation + vbOKOnly
Exit Sub
End If
'Now getting the totals using Query
If cmbProducts.Text <> "" And cmbRegion.Text <> "" And cmbCustomerType.Text <> "" Then
strSQL = "SELECT Count([data$].[Call ID]) AS [CountOfCall ID], [data$].[Resolved] " & _
" FROM [Data$] WHERE ((([Data$].[Product]) = '" & cmbProducts.Text & "') And " & _
" (([Data$].[Region]) = '" & cmbRegion.Text & "') And (([Data$].[Customer Type]) = '" & cmbCustomerType.Text & "')) " & _
" GROUP BY [data$].[Resolved];"
closeRS
OpenDB
rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Range("L6").CopyFromRecordset rs
Else
Range("L6:M7").Clear
MsgBox "There was some issue getting the totals.", vbExclamation + vbOKOnly
Exit Sub
End If
End If
End If
End Sub
Private Sub cmdUpdateDropDowns_Click()
strSQL = "Select Distinct [Product] From [data$] Order by [Product]"
closeRS
OpenDB
cmbProducts.Clear
rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Do While Not rs.EOF
cmbProducts.AddItem rs.Fields(0)
rs.MoveNext
Loop
Else
MsgBox "I was not able to find any unique Products.", vbCritical + vbOKOnly
Exit Sub
End If
'----------------------------
strSQL = "Select Distinct [Region] From [data$] Order by [Region]"
closeRS
OpenDB
cmbRegion.Clear
rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Do While Not rs.EOF
cmbRegion.AddItem rs.Fields(0)
rs.MoveNext
Loop
Else
MsgBox "I was not able to find any unique Region(s).", vbCritical + vbOKOnly
Exit Sub
End If
'----------------------
strSQL = "Select Distinct [Customer Type] From [data$] Order by [Customer Type]"
closeRS
OpenDB
cmbCustomerType.Clear
rs.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
Do While Not rs.EOF
cmbCustomerType.AddItem rs.Fields(0)
rs.MoveNext
Loop
Else
MsgBox "I was not able to find any unique Customer Type(s).", vbCritical + vbOKOnly
Exit Sub
End If
End Sub
'OpenDB' có tạo kết nối cơ sở dữ liệu mới không? – Comintern
@Comintern Vâng, đúng vậy. – Norman
Thực hiện việc này mà không cần VBA có thể dễ dàng hơn https://www.youtube.com/watch?v=P9cUYpXIKsU – Slai