[已解决]如何修改从Access数据库里的姓名（曾为日期）来提取相应信息，谢谢！

qinhuan66

黄色区域现在是根据从Microsoft Access数据库的年份来提取数据，如何修改从Microsoft Access数据库里的姓名来提取相应信息，谢谢！

报销统计表（测试）.rar (37.31 KB, 下载次数: 5)

2013-5-18 17:52 上传

点击文件名下载附件

没改前的图例：



想改成的图例：


代码如下：

Sub 年度查询Access()
Range("A6:AG65536").ClearContents
With Sheets("年度报销统计查询")
        .Unprotect ("695360052")
        .[C55].FormulaR1C1 = ""
         .Protect ("695360052")
    End With
    Dim AccessFile As String, Database As String
    Dim arr(), i&, arrTemp
    Dim AdoConn As Object, AdoRst As Object
    Dim StrConn$, strSql$
    '检查是否输入年月
        If ([c3] < 1900 Or [c3] > 2099) Then
        MsgBox "请在C3单元格内输入要查询的月份"
        Exit Sub
    End If
    On Error GoTo Errcheck
    AccessFile = ThisWorkbook.Path & "\data.mdb"
    Database = "data"
    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 = [c3]  '修改这句
    'dateMonth = Month([c3])
    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 = 1
    For i = LBound(arrTemp) To UBound(arrTemp)
        lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
        '前5行是标题行，因为有合并格，强制从6行开始
        If lPos < 6 Then lPos = 6
        '判断是否超过5000行
        If lPos > 5000 Then
            Do
                lCol = lCol + 6
                lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
                If lPos < 6 Then lPos = 6
            Loop Until lPos < 5000
        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

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-5-18 19:17

好早以前写的代码了，现在都不用这个格式了。

1. Sub 年度查询Access()
   
2. Range("A6:AG65536").ClearContents
   
3. With Sheets("年度报销统计查询")
   
4.         .Unprotect ("695360052")
   
5.         .[C55].FormulaR1C1 = ""
   
6.          .Protect ("695360052")
   
7.     End With
   
8.     Dim AccessFile As String, Database As String
   
9.     Dim arr(), i&, arrTemp
   
10.     Dim AdoConn As Object, AdoRst As Object
    
11.     Dim StrConn$, strSql$
    
12.     Dim strName$
    
13.     '检查是否输入年月
    
14.         If Len([c3]) = 0 Then
    
15.         MsgBox "请在C3单元格内输入要查询的姓名"
    
16.         Exit Sub
    
17.     End If
    
18.     strName = [c3]
    
19.    
    
20.     On Error GoTo Errcheck
    
21.     AccessFile = ThisWorkbook.Path & "\data.mdb"
    
22.     Database = "data"
    
23.     If Dir(AccessFile) = "" Then
    
24.         MsgBox "ACCESS数据文件不存在"
    
25.         Exit Sub
    
26.     End If
    
27. 
    
28.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
29.               "Data Source=" & AccessFile & ";"""
    
30.     Set AdoConn = CreateObject("ADODB.Connection")
    
31.     With AdoConn
    
32.         .CursorLocation = 3    '游标类型
    
33.         .CommandTimeout = 5    '超时
    
34.         .connectionTimeout = 5  '超时
    
35.         .Open StrConn       '打开
    
36.     End With
    
37.     '检测ADO状态
    
38.     If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub
    
39.     '查询的年，月
    
40.         strSql = "select 报销月份,序号,定点医疗机构名称,医保卡号,单位名称,姓名,性别,年龄,入院日期,出院日期,住院天数,出院诊断,本次住院医疗费总额,甲类药费,乙类药费,进口药费,自费药费,超出范围,进口材料费,国产材料费,特殊检查费特殊治疗费,丙类项目,其它费用,起付段金额,个人政策自付小计,自费药品及自费项目,实际结算自付,统筹基金支付,大病求助基金支付,个人支付金额,本年住院次数,本年范围内费用累计,本年大病范围内费用累计 from " & Database & " where 姓名='" & strName & "'"
    
41.     Set AdoRst = AdoConn.Execute(strSql)
    
42.     If AdoRst.RecordCount = 0 Then
    
43.         MsgBox "无合乎条件的数据"
    
44.         Exit Sub
    
45.     Else
    
46.         Select Case AdoRst.RecordCount
    
47.         Case 1:
    
48.             arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
    
49.             ReDim arr(1 To 1, 1 To UBound(arrTemp))
    
50.             For i = LBound(arrTemp) To UBound(arrTemp)
    
51.                 arr(1, i) = arrTemp(i)
    
52.             Next
    
53.             arrTemp = arr
    
54.         Case Else:
    
55.             arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
    
56.         End Select
    
57.     End If
    
58.     AdoConn.Close
    
59.     Set AdoConn = Nothing
    
60.     '关刷屏
    
61.     Application.ScreenUpdating = False
    
62.     '列，行坐标
    
63.     Dim lCol&, lPos&, arr2
    
64.     lCol = 1
    
65.     For i = LBound(arrTemp) To UBound(arrTemp)
    
66.         lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
    
67.         '前5行是标题行，因为有合并格，强制从6行开始
    
68.         If lPos < 6 Then lPos = 6
    
69.         '判断是否超过5000行
    
70.         If lPos > 5000 Then
    
71.             Do
    
72.                 lCol = lCol + 6
    
73.                 lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
    
74.                 If lPos < 6 Then lPos = 6
    
75.             Loop Until lPos < 5000
    
76.         End If
    
77.         '按行写入，考虑到要写满要换列的情况
    
78.         arr2 = WorksheetFunction.Index(arrTemp, i, 0)
    
79.         Cells(lPos, lCol).Resize(, UBound(arr2)) = arr2
    
80.     Next
    
81.     '开刷屏，退出
    
82.     Application.ScreenUpdating = True
    
83.     Exit Sub
    
84. Errcheck:
    
85.     MsgBox Err.Number & vbNewLine & _
    
86.            Err.Description
    
87.            Stop
    
88.            Resume Next
    
89. End Sub
    
90. 
    

复制代码

跳转到最佳答案楼层

hwc2ycy

查询改成姓名不会？

qinhuan66

hwc2ycy 发表于 2013-5-18 19:10
查询改成姓名不会？

我改了语句不行。谢谢

hwc2ycy

好早以前写的代码了，现在都不用这个格式了。

1. Sub 年度查询Access()
   
2. Range("A6:AG65536").ClearContents
   
3. With Sheets("年度报销统计查询")
   
4.         .Unprotect ("695360052")
   
5.         .[C55].FormulaR1C1 = ""
   
6.          .Protect ("695360052")
   
7.     End With
   
8.     Dim AccessFile As String, Database As String
   
9.     Dim arr(), i&, arrTemp
   
10.     Dim AdoConn As Object, AdoRst As Object
    
11.     Dim StrConn$, strSql$
    
12.     Dim strName$
    
13.     '检查是否输入年月
    
14.         If Len([c3]) = 0 Then
    
15.         MsgBox "请在C3单元格内输入要查询的姓名"
    
16.         Exit Sub
    
17.     End If
    
18.     strName = [c3]
    
19.    
    
20.     On Error GoTo Errcheck
    
21.     AccessFile = ThisWorkbook.Path & "\data.mdb"
    
22.     Database = "data"
    
23.     If Dir(AccessFile) = "" Then
    
24.         MsgBox "ACCESS数据文件不存在"
    
25.         Exit Sub
    
26.     End If
    
27. 
    
28.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
29.               "Data Source=" & AccessFile & ";"""
    
30.     Set AdoConn = CreateObject("ADODB.Connection")
    
31.     With AdoConn
    
32.         .CursorLocation = 3    '游标类型
    
33.         .CommandTimeout = 5    '超时
    
34.         .connectionTimeout = 5  '超时
    
35.         .Open StrConn       '打开
    
36.     End With
    
37.     '检测ADO状态
    
38.     If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub
    
39.     '查询的年，月
    
40.         strSql = "select 报销月份,序号,定点医疗机构名称,医保卡号,单位名称,姓名,性别,年龄,入院日期,出院日期,住院天数,出院诊断,本次住院医疗费总额,甲类药费,乙类药费,进口药费,自费药费,超出范围,进口材料费,国产材料费,特殊检查费特殊治疗费,丙类项目,其它费用,起付段金额,个人政策自付小计,自费药品及自费项目,实际结算自付,统筹基金支付,大病求助基金支付,个人支付金额,本年住院次数,本年范围内费用累计,本年大病范围内费用累计 from " & Database & " where 姓名='" & strName & "'"
    
41.     Set AdoRst = AdoConn.Execute(strSql)
    
42.     If AdoRst.RecordCount = 0 Then
    
43.         MsgBox "无合乎条件的数据"
    
44.         Exit Sub
    
45.     Else
    
46.         Select Case AdoRst.RecordCount
    
47.         Case 1:
    
48.             arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
    
49.             ReDim arr(1 To 1, 1 To UBound(arrTemp))
    
50.             For i = LBound(arrTemp) To UBound(arrTemp)
    
51.                 arr(1, i) = arrTemp(i)
    
52.             Next
    
53.             arrTemp = arr
    
54.         Case Else:
    
55.             arrTemp = WorksheetFunction.Transpose(AdoRst.GetRows)
    
56.         End Select
    
57.     End If
    
58.     AdoConn.Close
    
59.     Set AdoConn = Nothing
    
60.     '关刷屏
    
61.     Application.ScreenUpdating = False
    
62.     '列，行坐标
    
63.     Dim lCol&, lPos&, arr2
    
64.     lCol = 1
    
65.     For i = LBound(arrTemp) To UBound(arrTemp)
    
66.         lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
    
67.         '前5行是标题行，因为有合并格，强制从6行开始
    
68.         If lPos < 6 Then lPos = 6
    
69.         '判断是否超过5000行
    
70.         If lPos > 5000 Then
    
71.             Do
    
72.                 lCol = lCol + 6
    
73.                 lPos = Cells(Rows.Count, lCol).End(xlUp).Row + 1
    
74.                 If lPos < 6 Then lPos = 6
    
75.             Loop Until lPos < 5000
    
76.         End If
    
77.         '按行写入，考虑到要写满要换列的情况
    
78.         arr2 = WorksheetFunction.Index(arrTemp, i, 0)
    
79.         Cells(lPos, lCol).Resize(, UBound(arr2)) = arr2
    
80.     Next
    
81.     '开刷屏，退出
    
82.     Application.ScreenUpdating = True
    
83.     Exit Sub
    
84. Errcheck:
    
85.     MsgBox Err.Number & vbNewLine & _
    
86.            Err.Description
    
87.            Stop
    
88.            Resume Next
    
89. End Sub
    
90. 
    

复制代码

hwc2ycy

改了下，有些已经在这里不适合用了。

1. Sub 年度查询Access()
   
2.     Range("A6:AG65536").ClearContents
   
3.     With Sheets("年度报销统计查询")
   
4.         .Unprotect ("695360052")
   
5.         .[C55].FormulaR1C1 = ""
   
6.         .Protect ("695360052")
   
7.     End With
   
8.     Dim AccessFile As String, Database As String
   
9.     Dim arr(), i&, arrTemp
   
10.     Dim AdoConn As Object, AdoRst As Object
    
11.     Dim StrConn$, strSql$
    
12.     Dim strName$
    
13. 
    
14. 
    
15.     AccessFile = ThisWorkbook.Path & "\data.mdb"
    
16.     Database = "data"
    
17. 
    
18.     If Len([c3]) = 0 Then
    
19.         MsgBox "模糊查询开始"
    
20.         strSql = "select 报销月份,序号,定点医疗机构名称,医保卡号,单位名称,姓名,性别,年龄,入院日期,出院日期,住院天数,出院诊断,本次住院医疗费总额,甲类药费,乙类药费,进口药费,自费药费,超出范围,进口材料费,国产材料费,特殊检查费特殊治疗费,丙类项目,其它费用,起付段金额,个人政策自付小计,自费药品及自费项目,实际结算自付,统筹基金支付,大病求助基金支付,个人支付金额,本年住院次数,本年范围内费用累计,本年大病范围内费用累计 from " & Database    '‘ & " where 姓名='" & strName & "'"
    
21.     Else
    
22.         strName = [c3]
    
23.         strSql = "select 报销月份,序号,定点医疗机构名称,医保卡号,单位名称,姓名,性别,年龄,入院日期,出院日期,住院天数,出院诊断,本次住院医疗费总额,甲类药费,乙类药费,进口药费,自费药费,超出范围,进口材料费,国产材料费,特殊检查费特殊治疗费,丙类项目,其它费用,起付段金额,个人政策自付小计,自费药品及自费项目,实际结算自付,统筹基金支付,大病求助基金支付,个人支付金额,本年住院次数,本年范围内费用累计,本年大病范围内费用累计 from " & Database & " where 姓名='" & strName & "'"
    
24.     End If
    
25. 
    
26. 
    
27.     On Error GoTo Errcheck
    
28.     If Dir(AccessFile) = "" Then
    
29.         MsgBox "ACCESS数据文件不存在"
    
30.         Exit Sub
    
31.     End If
    
32. 
    
33.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
34.               "Data Source=" & AccessFile & ";"""
    
35. 
    
36.     Set AdoConn = CreateObject("ADODB.Connection")
    
37.     With AdoConn
    
38.         .CursorLocation = 3    '游标类型
    
39.         .CommandTimeout = 5    '超时
    
40.         .connectionTimeout = 5  '超时
    
41.         .Open StrConn       '打开
    
42.     End With
    
43. 
    
44.     Set AdoRst = AdoConn.Execute(strSql)
    
45. 
    
46.     If AdoRst.RecordCount = 0 Then
    
47.         MsgBox "无合乎条件的数据"
    
48.         Exit Sub
    
49.     Else
    
50.         Application.ScreenUpdating = False
    
51.         Range("a6").CopyFromRecordset AdoRst
    
52.     End If
    
53.     AdoConn.Close
    
54.     Set AdoConn = Nothing
    
55.     Application.ScreenUpdating = True
    
56.     MsgBox "查询完成"
    
57.     Exit Sub
    
58. Errcheck:
    
59.     MsgBox Err.Number & vbNewLine & _
    
60.            Err.Description
    
61. End Sub
    

复制代码

hwc2ycy

再精简下。

1. Sub 年度查询Access()
   
2.     Range("A6:AG65536").ClearContents
   
3.     With Sheets("年度报销统计查询")
   
4.         .Unprotect ("695360052")
   
5.         .[C55].FormulaR1C1 = ""
   
6.         .Protect ("695360052")
   
7.     End With
   
8.    
   
9.     Dim AccessFile As String, Database As String
   
10.     Dim AdoConn As Object, AdoRst As Object
    
11.     Dim StrConn$, strSql$
    
12. 
    
13.     On Error GoTo Errcheck
    
14.     If Dir(AccessFile) = "" Then
    
15.         MsgBox "ACCESS数据文件不存在"
    
16.         Exit Sub
    
17.     End If
    
18. 
    
19.     AccessFile = ThisWorkbook.Path & "\data.mdb"
    
20.     Database = "data"
    
21.     strSql = "select 报销月份,序号,定点医疗机构名称,医保卡号,单位名称,姓名,性别,年龄,入院日期,出院日期,住院天数,出院诊断,本次住院医疗费总额,甲类药费,乙类药费,进口药费,自费药费,超出范围,进口材料费,国产材料费,特殊检查费特殊治疗费,丙类项目,其它费用,起付段金额,个人政策自付小计,自费药品及自费项目,实际结算自付,统筹基金支付,大病求助基金支付,个人支付金额,本年住院次数,本年范围内费用累计,本年大病范围内费用累计 from " & Database
    
22.    
    
23.     If Len([c3]) = 0 Then
    
24.         MsgBox "模糊查询开始"
    
25.     Else
    
26.         strSql = strSql & " where 姓名='" & [c3] & "'"
    
27.     End If
    
28. 
    
29.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
30.               "Data Source=" & AccessFile & ";"""
    
31. 
    
32.     Set AdoConn = CreateObject("ADODB.Connection")
    
33.     With AdoConn
    
34.         .CursorLocation = 3    '游标类型
    
35.         .CommandTimeout = 5    '超时
    
36.         .connectionTimeout = 5  '超时
    
37.         .Open StrConn       '打开
    
38.     End With
    
39. 
    
40.     Set AdoRst = AdoConn.Execute(strSql)
    
41. 
    
42.     If AdoRst.RecordCount = 0 Then
    
43.         MsgBox "无合乎条件的数据"
    
44.         Exit Sub
    
45.     Else
    
46.         Application.ScreenUpdating = False
    
47.         Range("a6").CopyFromRecordset AdoRst
    
48.     End If
    
49.     AdoConn.Close
    
50.     Set AdoConn = Nothing
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "查询完成"
    
53.     Exit Sub
    
54.    
    
55. Errcheck:
    
56.     MsgBox Err.Number & vbNewLine & _
    
57.            Err.Description
    
58. End Sub

复制代码