Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 5292|回复: 16

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

[复制链接]
发表于 2013-4-2 15:54 | 显示全部楼层 |阅读模式
老师能否做到在黄色区域输入月份能自动从Microsoft Access数据库提取缴款人、成年人正常缴费、未成年人正常缴费、金额到查询这个工作表.谢谢

附件: 社会保险基金专用收款收据.rar (26.8 KB, 下载次数: 20)
发表于 2013-4-2 16:46 | 显示全部楼层
  1. Sub 查询Access()


  2.     Dim AccessFile As String, Database As String, SQL As String
  3.     Dim StrConn$, strSql$
  4.     Dim lLastrow&
  5.     Dim arr, i&, j As Byte

  6.     Dim AdoConn As Object
  7.     Dim AdoRst As Object

  8.     Dim arrTemp


  9.     If Len([c1]) = 0 Then
  10.         MsgBox "请在C1单元格内输入要查询的年月"
  11.         Exit Sub
  12.     End If

  13.     On Error GoTo Errcheck
  14.     AccessFile = ThisWorkbook.Path & "\收款收据.mdb"
  15.     Database = "收款信息"
  16.     If Dir(AccessFile) = "" Then
  17.         MsgBox "ACCESS数据文件不存在"
  18.         Exit Sub
  19.     End If


  20.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
  21.               "Data Source=" & AccessFile & ";"""

  22.     Set AdoConn = CreateObject("ADODB.Connection")
  23.     With AdoConn

  24.         .CursorLocation = 3
  25.         '.Mode = 1
  26.         .CommandTimeout = 5
  27.         .connectionTimeout = 5
  28.         .Open StrConn
  29.     End With

  30.     If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub

  31.     Dim dateYear As Integer, dateMonth As Byte
  32.     dateYear = Year([c1])
  33.     dateMonth = Month([c1])
  34.     strSql = "select 缴款人,成年人正常缴费,未成年人正常缴费,金额 from " & Database & " where year(委托日期)=" & dateYear & " and month(委托日期)=" & dateMonth

  35.     Set AdoRst = AdoConn.Execute(strSql)
  36.     'MsgBox AdoRst.RecordCount
  37.     If AdoRst.RecordCount = 0 Then
  38.         MsgBox "无合乎条件的数据"
  39.     Else
  40.         Select Case AdoRst.RecordCount
  41.             Case 1:
  42.                 arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
  43.                 ReDim arr(1 To 1, 1 To UBound(arrTemp))
  44.                 For i = LBound(arrTemp) To UBound(arrTemp)
  45.                     arr(1, i) = arrTemp(i)
  46.                 Next
  47.                 arrTemp = arr
  48.             Case 2:
  49.                 arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
  50.         End Select
  51.     End If

  52.     AdoConn.Close
  53.     Set AdoConn = Nothing
  54.     If IsArray(arrTemp) Then
  55.         Application.ScreenUpdating = False
  56.         Dim lCol&, lRow&, lPos&, arr2
  57.         lCol = 2
  58.         For i = LBound(arrTemp) To UBound(arrTemp)
  59.             lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
  60.             If lPos < 5 Then lPos = 5
  61.             If lPos > 54 Then
  62.                 Do
  63.                     lCol = lCol + 5
  64.                     lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
  65.                     If lPos < 5 Then lPos = 5
  66.                 Loop Until lPos < 55
  67.             End If
  68.             arr2 = WorksheetFunction.Index(arrTemp, i, 0)

  69.             Cells(lPos, lCol).Resize(, UBound(arr2)) = arr2
  70.         Next
  71.         Application.ScreenUpdating = True
  72.     End If
  73.     Exit Sub
  74. Errcheck:

  75.     MsgBox Err.Number & vbNewLine & _
  76.            Err.Description
  77. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
qinhuan66 + 1 谢谢您了老师!

查看全部评分

回复

使用道具 举报

发表于 2013-4-2 16:48 | 显示全部楼层
因为分了几列,所以得判断是否写到54了,然后还要换列。
回复

使用道具 举报

 楼主| 发表于 2013-4-2 17:00 | 显示全部楼层
本帖最后由 qinhuan66 于 2013-4-2 17:23 编辑
hwc2ycy 发表于 2013-4-2 16:48
因为分了几列,所以得判断是否写到54了,然后还要换列。

不好意思,我删除旧数据库重新生成可以了。谢谢
回复

使用道具 举报

 楼主| 发表于 2013-4-2 17:29 | 显示全部楼层
hwc2ycy 发表于 2013-4-2 16:46

教师发现一个问题:提取出来后,新提交到数据库的就提取不出工作表。谢谢
回复

使用道具 举报

发表于 2013-4-2 17:31 | 显示全部楼层
提不出来,那是月份的问题,是不是提示无符合条件的数据?
回复

使用道具 举报

发表于 2013-4-2 17:31 | 显示全部楼层
还有也会比对年是否相同。
回复

使用道具 举报

 楼主| 发表于 2013-4-2 17:34 | 显示全部楼层
hwc2ycy 发表于 2013-4-2 17:31
还有也会比对年是否相同。

附件:
社会保险基金专用收款收据.rar (35.99 KB, 下载次数: 13)
回复

使用道具 举报

发表于 2013-4-2 17:48 | 显示全部楼层
  1. Sub 查询Access()

  2.     Dim AccessFile As String, Database As String, SQL As String
  3.     Dim StrConn$, strSql$
  4.     Dim lLastrow&
  5.     Dim arr, i&, j As Byte

  6.     Dim AdoConn As Object
  7.     Dim AdoRst As Object

  8.     Dim arrTemp


  9.     If Len([c1]) = 0 Then
  10.         MsgBox "请在C1单元格内输入要查询的年月"
  11.         Exit Sub
  12.     End If

  13.     On Error GoTo Errcheck
  14.     AccessFile = ThisWorkbook.Path & "\收款收据.mdb"
  15.     Database = "收款信息"
  16.     If Dir(AccessFile) = "" Then
  17.         MsgBox "ACCESS数据文件不存在"
  18.         Exit Sub
  19.     End If


  20.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
  21.               "Data Source=" & AccessFile & ";"""

  22.     Set AdoConn = CreateObject("ADODB.Connection")
  23.     With AdoConn

  24.         .CursorLocation = 3
  25.         '.Mode = 1
  26.         .CommandTimeout = 5
  27.         .connectionTimeout = 5
  28.         .Open StrConn
  29.     End With

  30.     If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub

  31.     Dim dateYear As Integer, dateMonth As Byte
  32.     dateYear = Year([c1])
  33.     dateMonth = Month([c1])
  34.     strSql = "select 缴款人,成年人正常缴费,未成年人正常缴费,金额 from " & Database & " where year(委托日期)=" & dateYear & " and month(委托日期)=" & dateMonth

  35.     Set AdoRst = AdoConn.Execute(strSql)
  36.     'MsgBox AdoRst.RecordCount
  37.     If AdoRst.RecordCount = 0 Then
  38.         MsgBox "无合乎条件的数据"
  39.     Else
  40.         Select Case AdoRst.RecordCount
  41.             Case 1:
  42.                 arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
  43.                 ReDim arr(1 To 1, 1 To UBound(arrTemp))
  44.                 For i = LBound(arrTemp) To UBound(arrTemp)
  45.                     arr(1, i) = arrTemp(i)
  46.                 Next
  47.                 arrTemp = arr
  48.             Case Else:
  49.             
  50.                 arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
  51.         End Select
  52.     End If

  53.     AdoConn.Close
  54.     Set AdoConn = Nothing
  55.     If IsArray(arrTemp) Then
  56.         Application.ScreenUpdating = False
  57.         Dim lCol&, lRow&, lPos&, arr2
  58.         lCol = 2
  59.         For i = LBound(arrTemp) To UBound(arrTemp)
  60.             lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
  61.             If lPos < 5 Then lPos = 5
  62.             If lPos > 54 Then
  63.                 Do
  64.                     lCol = lCol + 5
  65.                     lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
  66.                     If lPos < 5 Then lPos = 5
  67.                 Loop Until lPos < 55
  68.             End If
  69.             arr2 = WorksheetFunction.Index(arrTemp, i, 0)

  70.             Cells(lPos, lCol).Resize(, UBound(arr2)) = arr2
  71.         Next
  72.         Application.ScreenUpdating = True
  73.     End If
  74.     Exit Sub
  75. Errcheck:

  76.     MsgBox Err.Number & vbNewLine & _
  77.            Err.Description
  78. End Sub
复制代码
有个地方写错了,不好意思。
代码还没优化的,只是初步写了,明天再帮你优化吧。
回复

使用道具 举报

发表于 2013-4-2 18:00 | 显示全部楼层    本楼为最佳答案   
  1. Sub 查询Access()
  2.     Dim AccessFile As String, Database As String
  3.     Dim arr(), i&, arrTemp
  4.     Dim AdoConn As Object, AdoRst As Object
  5.     Dim StrConn$, strSql$
  6.    
  7.     '检查是否输入年月
  8.     If Not (Len([c1]) = 0 Or IsDate([c1])) Then
  9.         MsgBox "请在C1单元格内输入要查询的年月"
  10.         Exit Sub
  11.     End If

  12.     On Error GoTo Errcheck

  13.     AccessFile = ThisWorkbook.Path & "\收款收据.mdb"
  14.     Database = "收款信息"
  15.     If Dir(AccessFile) = "" Then
  16.         MsgBox "ACCESS数据文件不存在"
  17.         Exit Sub
  18.     End If


  19.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
  20.               "Data Source=" & AccessFile & ";"""

  21.     Set AdoConn = CreateObject("ADODB.Connection")

  22.     With AdoConn
  23.         .CursorLocation = 3    '游标类型
  24.         .CommandTimeout = 5    '超时
  25.         .connectionTimeout = 5  '超时
  26.         .Open StrConn       '打开
  27.     End With

  28.     '检测ADO状态
  29.     If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub

  30.     '查询的年,月
  31.     Dim dateYear As Integer, dateMonth As Byte
  32.     dateYear = Year([c1])
  33.     dateMonth = Month([c1])

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

  35.     Set AdoRst = AdoConn.Execute(strSql)

  36.     If AdoRst.RecordCount = 0 Then
  37.         MsgBox "无合乎条件的数据"
  38.         Exit Sub
  39.     Else
  40.         Select Case AdoRst.RecordCount
  41.             Case 1:
  42.                 arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
  43.                 ReDim arr(1 To 1, 1 To UBound(arrTemp))
  44.                 For i = LBound(arrTemp) To UBound(arrTemp)
  45.                     arr(1, i) = arrTemp(i)
  46.                 Next
  47.                 arrTemp = arr
  48.             Case Else:
  49.                 arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
  50.         End Select
  51.     End If

  52.     AdoConn.Close
  53.     Set AdoConn = Nothing

  54.     '关刷屏
  55.     Application.ScreenUpdating = False

  56.     '列,行坐标
  57.     Dim lCol&, lPos&, arr2
  58.     lCol = 2

  59.     For i = LBound(arrTemp) To UBound(arrTemp)
  60.         lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
  61.         '前4行是标题行,因为有合并格,强制从5行开始
  62.         If lPos < 5 Then lPos = 5
  63.         '判断是否超过54行
  64.         If lPos > 54 Then
  65.             Do
  66.                 lCol = lCol + 5
  67.                 lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
  68.                 If lPos < 5 Then lPos = 5
  69.             Loop Until lPos < 55
  70.         End If
  71.         '按行写入,考虑到要写满要换列的情况
  72.         arr2 = WorksheetFunction.Index(arrTemp, i, 0)

  73.         Cells(lPos, lCol).Resize(, UBound(arr2)) = arr2
  74.     Next
  75.     '开刷屏,退出
  76.     Application.ScreenUpdating = True
  77.     Exit Sub

  78. Errcheck:
  79.     MsgBox Err.Number & vbNewLine & _
  80.            Err.Description
  81. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
qinhuan66 + 1 很给力!谢谢

查看全部评分

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 14:59 , Processed in 0.592751 second(s), 17 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表