|
- Sub 查询Access()
- Dim AccessFile As String, Database As String, SQL As String
- Dim StrConn$, strSql$
- Dim lLastrow&
- Dim arr, i&, j As Byte
- Dim AdoConn As Object
- Dim AdoRst As Object
- Dim arrTemp
- If Len([c1]) = 0 Then
- MsgBox "请在C1单元格内输入要查询的年月"
- Exit Sub
- End If
- On Error GoTo Errcheck
- AccessFile = ThisWorkbook.Path & "\收款收据.mdb"
- Database = "收款信息"
- If Dir(AccessFile) = "" Then
- MsgBox "ACCESS数据文件不存在"
- Exit Sub
- End If
- StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
- "Data Source=" & AccessFile & ";"""
- Set AdoConn = CreateObject("ADODB.Connection")
- With AdoConn
- .CursorLocation = 3
- '.Mode = 1
- .CommandTimeout = 5
- .connectionTimeout = 5
- .Open StrConn
- End With
- If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub
- Dim dateYear As Integer, dateMonth As Byte
- dateYear = Year([c1])
- dateMonth = Month([c1])
- strSql = "select 缴款人,成年人正常缴费,未成年人正常缴费,金额 from " & Database & " where year(委托日期)=" & dateYear & " and month(委托日期)=" & dateMonth
- Set AdoRst = AdoConn.Execute(strSql)
- 'MsgBox AdoRst.RecordCount
- If AdoRst.RecordCount = 0 Then
- MsgBox "无合乎条件的数据"
- Else
- Select Case AdoRst.RecordCount
- Case 1:
- arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
- ReDim arr(1 To 1, 1 To UBound(arrTemp))
- For i = LBound(arrTemp) To UBound(arrTemp)
- arr(1, i) = arrTemp(i)
- Next
- arrTemp = arr
- Case Else:
-
- arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
- End Select
- End If
- AdoConn.Close
- Set AdoConn = Nothing
- If IsArray(arrTemp) Then
- Application.ScreenUpdating = False
- Dim lCol&, lRow&, lPos&, arr2
- lCol = 2
- For i = LBound(arrTemp) To UBound(arrTemp)
- lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
- If lPos < 5 Then lPos = 5
- If lPos > 54 Then
- Do
- lCol = lCol + 5
- lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
- If lPos < 5 Then lPos = 5
- Loop Until lPos < 55
- End If
- arr2 = WorksheetFunction.Index(arrTemp, i, 0)
- Cells(lPos, lCol).Resize(, UBound(arr2)) = arr2
- Next
- Application.ScreenUpdating = True
- End If
- Exit Sub
- Errcheck:
- MsgBox Err.Number & vbNewLine & _
- Err.Description
- End Sub
复制代码 有个地方写错了,不好意思。
代码还没优化的,只是初步写了,明天再帮你优化吧。 |
|