一些常用的vba代码合集，方便检索引用
模块1：生成workbook下的目录
Attribute VB_Name = "Basic"
Option Explicit
Sub Generate_Content_General()
Application.ScreenUpdating = False
'第一部分：声明基础变量
Dim sht As Worksheet
Dim sht_content As Worksheet
Dim wk As Workbook
Set wk = ThisWorkbook
Set sht_content = wk.Sheets("目录")
With sht_content.Cells(2, 2)
.Value = "目录"
.Offset(0, 1) = "超链接"
End With
'第二部分：超链接
Dim i, j, k
Dim zstr, ystr, xstr
j = 2
i = 2
Do While i < wk.Sheets.Count
Set sht = wk.Sheets(i)
If sht.Name <> "目录" And sht.Visible = -1 Then
With sht_content.Cells(j + 1, 2)
.Value = sht.Name
sht_content.Hyperlinks.Add .Offset(0, 1), Address:="", SubAddress:="'" & sht.Name & "'!a1", TextToDisplay:="点击链接表"
'逆向链接过程
j = j + 1
End With
End If
i = i + 1
Loop
With sht_content.Range("b:c")
.Columns.AutoFit
.Font.Size = 12
End With
Application.ScreenUpdating = True
End Sub模块2：移动目录到第一个位置
Sub move_sheet_index()
Dim wb As Workbook
Dim sht As Worksheet
Dim dht As Worksheet
Dim i
Dim sheet_name
Dim index
Set wb = ThisWorkbook
Set sht = wb.Sheets("目录")
For i = 2 To 38
sheet_name = sht.Cells(i, 2)
index = sht.Cells(i, 7)
wb.Sheets(sheet_name).Move After:=Sheets(i - 1)
Next
End Sub模块3：更新目录
Sub Update_Content()
Application.ScreenUpdating = False
Dim wk As Workbook
Dim sht_content As Worksheet
Set wk = ThisWorkbook
Set sht_content = wk.Sheets("目录")
sht_content.Range("b:c").ClearContents
Call Generate_Content_General
Application.ScreenUpdating = True
End Sub模块4：取消隐藏单元格
Sub Cancel_Hidden()
Dim sht As Worksheet
For Each sht In Sheets
sht.Visible = xlSheetVisible
Next
End Sub
模块5：删除workbook下的代码模块
Sub 删除代码() '这个程序要在标准的Moudle模块中
Dim i, icon
Dim vbc As Object
Dim wk As Workbook
Dim sht As Worksheet
Dim arr
Set wk = ThisWorkbook
Set sht = wk.Sheets("Draft")
icon = wk.VBProject.VBComponents.Count
ReDim arr(1 To icon, 2)
For i = 1 To icon
If i > icon Then Exit For
Set vbc = wk.VBProject.VBComponents(i)
' arr(i, 0) = i
' arr(i, 1) = vbc.Name
' arr(i, 2) = vbc.Type
If vbc.Type = 1 And vbc.Name <> "Delete_Model" And vbc.Name <> "Func" Then
With Application.VBE.ActiveVBProject.VBComponents
.Remove .Item(vbc.Name) '删除模块、类模块、窗体
End With
i = i - 1
icon = icon - 1
End If
Next
'sht.[a1].Resize(UBound(arr, 1), UBound(arr, 2) + 1) = arr
End Sub模块6：vba中用sql模块
Function exe_sql(ds, sql As String)
Dim conn As Object
Dim spath$
Dim i As Integer, j, k%, t As Integer, Trow%, Tcolumn%
Dim columns, data
Dim rst As Object
Set conn = CreateObject("adodb.connection")
Set rst = CreateObject("adodb.recordset")
conn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;imex=1';data source= " & ds
If sql = "" Then
MsgBox "请输入SQL语句"
Exit Function
Else
rst.Open sql, conn, 3
i = rst.Fields.Count
ReDim columns(1 To i)
' 记录获取的列名
For k = 1 To i
columns(k) = rst.Fields(k - 1).Name
Next
If rst.RecordCount > 0 Then j = rst.RecordCount
ReDim data(1 To j, 1 To i)
t = 1
Do While rst.EOF = False
For k = 1 To i
If Not IsNull(rst.Fields(k - 1)) Then
data(t, k) = rst.Fields(k - 1).Value
End If
Next
rst.movenext
t = t + 1
Loop
End If
exe_sql = Array(columns, data)
End Function
模块7：通用的一些function
Function Extract(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 = 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
i = rst.RecordCount
If i
