利用表格作为数据库

wcj109

Dim cnn, rs, rs1, tab1, mycmd, nam '模块级变量
Sub 连接数据库()‘利用表格作为数据库
        Set cnn = CreateObject("ADODB.Connection")
        Set rs = CreateObject("ADODB.Recordset")
        Set
rs1 = CreateObject("ADODB.Recordset")
        Set mycmd = CreateObject("ADODB.command")
                                                '            If Dir(ThisWorkbook.Path & "\" & "*.mdb") = "答题查询.mdb" Then
                                                '                my = ThisWorkbook.Path & "\答题查询.mdb " '连接数据库 ace.OLEDB.12.0  jet.OLEDB.4.0";Extended Properties=Excel 8.0;
                                                '                Else
                                                '                my = "d:/数据库/答题查询.mdb"
                                                '            End If
my = ThisWorkbook.FullName '完整路径
tab1 = "[" & Sheet3.Range("F2") & "$]" '表格名称  
             If Application.Version < 12 Or InStr(Replace(UCase(Application.Caption), UCase(Application.ActiveWorkbook.Name), ""), "WPS") > 0 Then 'Application.Caption标题栏文本
                cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & my ' & ";hdr=yes;imex=1" '表格连接
'                cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Data Source=" & my '连接数据库 ace.OLEDB.12.0  jet.OLEDB.4.0’access作为数据库
                         Else
                 cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & my '& ";hdr=yes;imex=1" '表格连接
'                cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & my
            End If      
End Sub
‘写入工作表
Sub 写入表格1()
b = Range("b60000").End(xlUp).Row
h = Range("iv3").End(xlToLeft).Column
' On Error Resume Next
If rs.RecordCount > 0 Then
    rs.MoveFirst
   Range(Range("a3"), Cells(b, h)).Clear 'Contents
End If
    If Not rs.EOF Then
             '     Sheet1.[b2].CopyFromRecordset rs
                   [a3] = "序号"
          For i = 0 To rs.Fields.Count - 1
                   Cells(3, i + 2) = rs.Fields(i).Name '表头名称
          Next

            For i = 1 To rs.RecordCount
                  For j = 0 To rs.Fields.Count - 1
                        Cells(i + 3, j + 2) = rs.Fields(j) '添加行
                 Next j
                  rs.MoveNext
            Next i
           Columns("b:b").NumberFormatLocal = "yyyy/m/d" '设置b列为日期格式
    '        Sheet3.Range("e:e").NumberFormatLocal = "@"

               '1\添加序号
                    i = 1
                    Do
                       Range("a" & i + 3) = i
                       i = i + 1
                    Loop While Range("b" & i + 3) <> ""

                '2\设置表格格式
    '             Sheet1.Activate
           Call 设置表格格式
       Else
                Range("a4:ag65355").Clear
                MsgBox "没有查到"
     End If
End Sub


Sub 设置表格格式()
  row1 = Range("a63535").End(xlUp).Row '表格总的行数
  col = Range("a3").End(xlToRight).Column '表格总的列数
  bi = 3 '标题行行号，颜色,蓝色
  qi = 4 '单元格区域起始行号
  
      With Range(Cells(qi, 1), Cells(row1, col)) '数据区域大概设置
        '1、单元格边框、颜色
        '   .Borders.LineStyle = 0 '去边框3行1列起
            .Borders.LineStyle = 1
        '   .Borders.ColorIndex = 5 '边框颜色
         
          '2、调整单元格的字体及颜色大小
             .Font.Name = "宋体" '"仿宋体"
        '     Range("a3:q" & i).Font.FontStyle = "Bold"
             .Font.Bold = False '是否粗体
             .Font.ColorIndex = 1
             .Font.Size = 10
         '3调整行列的宽高度及换行
         .WrapText = True '自动换行
        .Rows.AutoFit '自动调整行高
'        .Columns.AutoFit '自动调整列宽
        
    End With
    With Range(Cells(bi, 1), Cells(bi, col))
     '4、调整标题行的宽度和字体加深
        .Interior.ColorIndex = 37 '调整单元格颜色,第二行蓝色
       .Font.Bold = True '第二行字体加深
       .Font.Size = 10
       .Borders.LineStyle = 1
        .RowHeight = 26 '调整第二行的行高,columnwidth=3列宽
'         .Columns.AutoFit '自动调整列宽
    End With
    '5、单独调整列宽度和字体加深
    Range(Cells(bi, 1), Cells(row1, col)).Columns.AutoFit '自动调整列宽
'        Range("d:d").ColumnWidth = 25 'b列列宽设置
'        Range("b:b").ColumnWidth = 9.13
'        Range("c:c").ColumnWidth = 9
'        Range("e:e").ColumnWidth = 13
        
                '        Range("ah:ah").Font.Size = 9
End Sub

sub 查询（）'利用sql语句查谒
Call 连接数据库
sql="select *  from  "  &  tab1  
rs.Open Sql, cnn, 1, 3
Sheet3.Activate'写入sheet3表格
Call 写入表格1


rs.Close
  cnn.Close
   Set cnn = Nothing

end sub

高个子

给你点赞了

洋务德雷

代码虽然分过程写了，感觉不整齐，有些乱。
送你一个模块吧

1. Option Explicit
   
2. '**********************************************************
   
3. '*****2022/12/29  整理这个模块，以便方便以后使用********
   
4. '*****                        丹哥编辑                                        ********
   
5. '*****本模块用于sql代码调用Excel工作簿的数据源数据******
   
6. '***********************************************************
   
7. '单独使用本模块，需要设置全局变量wbFullName
   
8. 
   
9. Public wbFullName As String
   
10. 
    
11. '通用的输入sql公式来查询得出数组(不包括标题)
    
12. Public Function ESQlArrNoTitle(sql As String)
    
13.     'SQLArr最终为数组形式
    
14.     Dim rs As Object, cn As Object
    
15.     Dim arr(), i%, j%
    
16.    ReDim arr(0 To 0, 0 To 0)
    
17.     Set rs = ESqlExecuteRecordset(sql)
    
18.     Set cn = rs.activeconnection
    
19.     '    Stop
    
20.     If rs.RecordCount > 0 Then
    
21.         ReDim arr(1 To rs.RecordCount, 1 To rs.Fields.Count)
    
22.         rs.MoveFirst
    
23.         For i = 1 To UBound(arr)
    
24.             For j = 1 To UBound(arr, 2)
    
25.                 arr(i, j) = rs.Fields(j - 1).Value
    
26.             Next j
    
27.             rs.movenext
    
28.         Next i
    
29.     End If
    
30.     '    Stop
    
31.     ESQlArrNoTitle = arr '如果没有查到结果，那么数组的最大小标就是0
    
32.     rs.Close: Set rs = Nothing
    
33.     cn.Close: Set cn = Nothing
    
34.     Erase arr
    
35. 
    
36. End Function
    
37. '通用的输入sql公式来查询得出数组(包括标题)
    
38. Public Function ESQlArr(sql As String)
    
39.     'SQLArr最终为数组形式
    
40.     Dim rs As Object, cn As Object
    
41.     Dim arr(), i%, j%
    
42.    ReDim arr(0 To 0, 0 To 0)
    
43.     Set rs = ESqlExecuteRecordset(sql)
    
44.     Set cn = rs.activeconnection
    
45.     '    Stop
    
46.     If rs.RecordCount > 0 Then
    
47.         ReDim arr(1 To rs.RecordCount + 1, 1 To rs.Fields.Count)
    
48.         rs.MoveFirst
    
49.         For i = 2 To UBound(arr)
    
50.             For j = 1 To UBound(arr, 2)
    
51.                 arr(i, j) = rs.Fields(j - 1).Value
    
52.             Next j
    
53.             rs.movenext
    
54.         Next i
    
55.         For j = 1 To UBound(arr, 2)
    
56.             arr(1, j) = rs.Fields(j - 1).Name
    
57.         Next j
    
58.     End If
    
59.    
    
60.     '    Stop
    
61.     ESQlArr = arr '如果没有查到结果，那么数组的最大小标就是0
    
62.     rs.Close: Set rs = Nothing
    
63.     cn.Close: Set cn = Nothing
    
64.     Erase arr
    
65. 
    
66. End Function
    
67. '连接数据库，返回连接对象
    
68. Private Function CreateConnectionE() As Object
    
69.       Dim cn As Object
    
70. '      wbFullName = ThisWorkbook.Path
    
71.       Set cn = CreateObject("Adodb.Connection")
    
72.       
    
73.       With cn
    
74.             .Provider = "Microsoft.Ace.Oledb.12.0;extended properties=excel 12.0"
    
75.             .Open wbFullName
    
76.       End With
    
77.       If Err.Number <> 0 Then
    
78.             Set CreateConnectionE = Nothing
    
79.       Else
    
80.             Set CreateConnectionE = cn
    
81.       End If
    
82. End Function
    
83. 
    
84. '执行增、删、改等操作的函数，不用返回值
    
85. Public Function ESqlExcuteNonQuery(sql As String) As Boolean
    
86.       Dim cn As Object
    
87. 
    
88.       Set cn = CreateConnectionE
    
89.       If cn Is Nothing Then   '连接失败
    
90.             ESqlExcuteNonQuery = False
    
91.             Exit Function
    
92.       End If
    
93. '      On Error Resume Next
    
94.       cn.Execute sql
    
95.       If Err.Number <> 0 Then
    
96.             cn.Close: Set cn = Nothing
    
97.             ESqlExcuteNonQuery = False
    
98.       Else
    
99.             cn.Close: Set cn = Nothing
    
100.             ESqlExcuteNonQuery = True
     
101.       End If
     
102. End Function
     
103. 
     
104. '执行SQL查询，返回单个值的函数
     
105. Public Function ESqlExecuteSingle(sql As String) As Variant
     
106.       Dim cn As Object, rs As Object
     
107. 
     
108.       Set cn = CreateConnectionE
     
109.       If cn Is Nothing Then '连接失败
     
110.             ESqlExecuteSingle = 0
     
111.             Exit Function
     
112.       End If
     
113.       On Error Resume Next
     
114.       Set rs = cn.Execute(sql)
     
115.       If Err.Number <> 0 Then
     
116.             ESqlExecuteSingle = 0
     
117.       Else
     
118.             If Not IsNull(rs.Fields(0).Value) Then
     
119.                   ESqlExecuteSingle = rs.Fields(0).Value
     
120.             Else
     
121.                   ESqlExecuteSingle = 0
     
122.             End If
     
123.       End If
     
124. End Function
     
125. 
     
126. '执行SQL查询，返回一个记录集
     
127. Private Function ESqlExecuteRecordset(sql As String) As Object
     
128.       Dim cn As Object, rs As Object
     
129. 
     
130.       Set cn = CreateConnectionE
     
131.       If cn Is Nothing Then  '连接失败
     
132.             Set ESqlExecuteRecordset = Nothing
     
133.             Exit Function
     
134.       End If
     
135.       On Error GoTo errFlag
     
136.       Set rs = CreateObject("Adodb.Recordset")
     
137.       rs.Open sql, cn, 3, 2
     
138.       Set ESqlExecuteRecordset = rs
     
139.       Exit Function
     
140. errFlag:
     
141.       Set ESqlExecuteRecordset = Nothing
     
142.       cn.Close: Set cn = Nothing
     
143. End Function
     
144. 
     

复制代码