首页 > 社交 > 科普中国

技巧篇:常用的vba代码汇总

常驻编辑 科普中国 2022-06-09 坐标轴   大前提   间距   数组   图表   模块   指标   常用   代码   业务   标题   技巧   目录

一些常用的vba代码合集,方便检索引用QYe拜客生活常识网

模块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     

相关阅读:

  • 魔幻工厂一字裤天猫旗舰店正式开售!三重好礼买到爽
  • 马桶两边留多少间距最为合适
  • 美国InfoComm
  • 班凯罗:若塔图姆在总决赛上出手更多中距离
  • 自驾游组队要注意的问题
  • 栏杆立杆间距规范要求 栏杆规范要求 栏杆长度规范 栏
  • 脸上有这5个特征,就是年纪越大越耐看的“抗老脸”,全中
  • 鼻头千万别再乱动了
  • 事关国庆假期出游,文旅部提醒!
  • 一个人开三辆车?奔驰测试无人驾驶卡车车队
    • 网站地图 |
    • 声明:登载此文出于传递更多信息之目的,并不意味着赞同其观点或证实其描述。文章内容仅供参考,不做权威认证,如若验证其真实性,请咨询相关权威专业人士。