<> "" And i >= 1 Then arr = rst.getrows(): rst.movefirst If Not IsArray(arr) Then Extract = Array("无记录"): Exit Function ReDim r_arr(UBound(arr, 2) + 1, UBound(arr, 1)) i = rst.Fields.Count '#@@@@# 这里属于标题部分 For j = 1 To i r_arr(0, j - 1) = rst.Fields(j - 1).Name Next rst.movefirst rst.Close: cnn.Close Set rst = Nothing: Set cnn = Nothing '#@@@@# 二维转换 For j = 0 To UBound(arr, 2) For i = 0 To UBound(arr) r_arr(j + 1, i) = arr(i, j) Next Next Extract = r_arr 'Debug.Print "Over" Exit Function '#@@@@# 错误提醒,on error resume next,on error goto err_handle,on error goto line,on error goto 0 Err_Handle: Extract = Err.Description End Function Function Extract_Origin(sql As String, f As String) '#@@ 拽数，并返回数组 Dim cnn As Object, rst As Object Dim r_arr, arr Dim i, j '#@@@@# 大前提 On Error GoTo Err_Handle If sql = "" Then Extract_Origin = 0: Exit Function '#@@@@# 正常执行 Set cnn = CreateObject("adodb.connection") Set rst = CreateObject("adodb.recordset") ' cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=YES';data source=" & f cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & f ' cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;imex=1';data source= " & f '# imex=1 数据导入模式 'rst = cnn.Execute(sql) | rng.copyfromrecordset rst | rst.fields.count | rst.recordcount rst.Open sql, cnn, 3 If rst.RecordCount > 0 Then arr = rst.getrows ReDim r_arr(UBound(arr, 2), UBound(arr, 1)) For j = 0 To UBound(arr, 2) For i = 0 To UBound(arr) r_arr(j, i) = arr(i, j) Next Next Else r_arr = 0 End If Extract_Origin = r_arr rst.Close cnn.Close Set rst = Nothing Set cnn = Nothing 'Debug.Print "Over" Exit Function '#@@@@# 错误提醒,on error resume next,on error goto err_handle,on error goto line,on error goto 0 Err_Handle: Extract_Origin = Err.Description End Function Function CheckWkOpen(ByVal f) Dim tk As Workbook Dim status status = 0 For Each tk In Workbooks If StrComp(f, "book1.xls", 1) = 0 Then MsgBox f & " is open" Application.Windows(f).Visible = True Workbooks(f).Close False status = 1 End If Next End Function Function CheckFile(spath) Dim fso As Object Set fso = CreateObject("scripting.filesystemobject") CheckExists = fso.fileexists(spath) End Function Function CheckTable(wk As Workbook, zstr As String) Dim sht As Worksheet Dim status For Each sht In wk.Sheets If sht.Name = zstr Then status = 1 Exit For Else status = 0 End If Next CheckTable = status End Function Sub tt() ActiveWorkbook.RemovePersonalInformation = False End Sub Function 拽数(sql As String, f As String) '@@拽数，并返回数组 Dim cnn As Object, rst As Object Dim r_arr, arr Dim i, j Set cnn = CreateObject("adodb.connection") Set rst = CreateObject("adodb.recordset") cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source= " & f On Error GoTo Err_Handle rst.Open sql, cnn, 3 i = rst.RecordCount If i <> "" And i >= 1 Then arr = rst.getrows(): rst.movefirst ReDim r_arr(UBound(arr, 2) + 1, UBound(arr, 1)) i = rst.Fields.Count For j = 1 To i r_arr(0, j - 1) = rst.Fields(j - 1).Name Next rst.movefirst rst.Close cnn.Close Set rst = Nothing Set cnn = Nothing For j = 0 To UBound(arr, 2) For i = 0 To UBound(arr) r_arr(j + 1, i) = arr(i, j) Next Next 拽数 = r_arr Set rst = Nothing Set cnn = Nothing Exit Function Err_Handle: Debug.Print Err.Description End Function

模块8：vba自动生成图表

Attribute VB_Name = "Generate_Chart"
Option Explicit

'=======================================下面为VBA自动生成部分=======================================
Sub Chart_Initial(C_row As Integer, C_column As Integer, ChartName As String, C_width As Integer, C_height)

'C_row,C_Column 存放行列位置,ChartName 存放表,C_width C_height 存放大小

Dim XTitle, YTitle
Dim Crng As Range, Xrng As Range, rng As Range
Dim sht As Worksheet, wb1 As Workbook
Dim MyChart As ChartObject
Dim R1, C, zstr

Set wb1 = ThisWorkbook
Set sht = wb1.Sheets("ChartData")

R1 = sht.ChartObjects.Count

If R1 > 0 Then
        For Each C In sht.ChartObjects
            zstr = C.Name
            If zstr = ChartName Then C.Delete
        Next
End If

'第一部分：创建一个新的图表Object事件
Set rng = sht.Cells(C_row, C_column)
Set MyChart = sht.ChartObjects.Add(rng.Left, rng.Offset(1, 0).Top, rng.Width * C_width, rng.Height * C_height)
With MyChart
        .Name = ChartName
End With

'第二部分：设置图表区格式
With MyChart.chart.ChartArea
        .Font.Name = "宋体"
        .Font.Size = 8
        .Font.ColorIndex = xlAutomatic
        .Border.LineStyle = 0
        .Interior.ColorIndex = xlAutomatic  '图表区填充
End With

'第三部分：设置绘图区格式
With MyChart.chart.PlotArea
        .Border.ColorIndex = 15
        .Border.Weight = xlThin
'        .Border.LineStyle = xlDot
        .Border.LineStyle = xlDot
        .Interior.ColorIndex = xlNone   '绘图区填充
End With

'第五部分：设置图表标题
MyChart.chart.HasTitle = True
With MyChart.chart.ChartTitle
        .Text = "