[已解决]黄色区域输入月份能自动从Access数据库提取缴款人

qinhuan66

hwc2ycy 发表于 2013-4-2 18:00

楼主经测试，发现一个问题提取时不会替换已生成的数据。每次提取都重复提取数据。谢谢
如图：

hwc2ycy

恩，不会替换已有的。都是追加。

qinhuan66

hwc2ycy 发表于 2013-4-2 18:53
恩，不会替换已有的。都是追加。

你好老师这个能处理吗？谢谢

qinhuan66

添加一句Range("B5:E54,G5:J54").ClearContents可以了谢谢

qinhuan66

hwc2ycy 发表于 2013-4-2 18:00

老师您好！现在碰到一个问题。您写的这条代码我想查询整年的数据，（注：现在是输入年月份查询月的数据），如何修改呢？谢谢

• Sub 查询Access()
•     Dim AccessFile As String, Database As String
•     Dim arr(), i&, arrTemp
•     Dim AdoConn As Object, AdoRst As Object
•     Dim StrConn$, strSql$
•     '检查是否输入年月
•     If Not (Len([c1]) = 0 Or IsDate([c1])) 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    '游标类型
•         .CommandTimeout = 5    '超时
•         .connectionTimeout = 5  '超时
•         .Open StrConn       '打开
•     End With
•     '检测ADO状态
•     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)
•     If AdoRst.RecordCount = 0 Then
•         MsgBox "无合乎条件的数据"
•         Exit Sub
•     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
•     '关刷屏
•     Application.ScreenUpdating = False
•     '列，行坐标
•     Dim lCol&, lPos&, arr2
•     lCol = 2
•     For i = LBound(arrTemp) To UBound(arrTemp)
•         lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
•         '前4行是标题行，因为有合并格，强制从5行开始
•         If lPos < 5 Then lPos = 5
•         '判断是否超过54行
•         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
•     Exit Sub
• Errcheck:
•     MsgBox Err.Number & vbNewLine & _
•            Err.Description
• End Sub
  

zjdh

把
43.    strSql = "select 缴款人,成年人正常缴费,未成年人正常缴费,金额 from " & Database & " where year(委托日期)=" & dateYear & " and month(委托日期)=" & dateMonth
改成
43.    strSql = "select 缴款人,成年人正常缴费,未成年人正常缴费,金额 from " & Database & " where year(委托日期)=" & dateYear

hannanrenjie

好厉害！