常用功能加载宏——工作簿目录

要创建工作簿的目录，其实就是遍历获取所有的文件，然后过滤一下，再增加超链接就可以：

首先在customUI.xml中增加代码：

代码语言：javascript复制

      <button id="rbbtnWorkbookDir" label="工作簿目录&#13;" onAction="rbbtnWorkbookDir" imageMso="FileSaveAsExcel97_2003" />

回调函数：

代码语言：javascript复制

Sub rbbtnWorkbookDir(control As IRibbonControl)
    Call MShtWk.WorkbookDir
End Sub

函数实现：

代码语言：javascript复制

Sub WorkbookDir()
    Dim i As Long
    Dim result() As Variant
    Dim rngout As Range
    
    On Error Resume Next
    Set rngout = Application.InputBox("请选择输出单元格", Default:=ActiveCell.Address, Type:=8)
    On Error GoTo 0
    
    If rngout Is Nothing Then
        Exit Sub
    End If
    '这里保证rngout只是单个的单元格，因为后面设置超链接的时候只要设置单个单元格
    Set rngout = rngout.Range("A1")
    
    Dim strDir As String
    Dim RetDirs() As String, RetFiles() As String
    '选择要查找的文件夹
    strDir = GetFolderPath()
    If VBA.Len(strDir) = 0 Then Exit Sub
    '遍历获取文件
    If ScanDir(strDir, RetDirs, RetFiles) = -1 Then Exit Sub
    
    '定义结果数组
    ReDim result(UBound(RetFiles)   1, 1) ' 1是因为有1个标题，可能会比RetFiles多一个

    result(0, 0) = "序号"
    result(0, 1) = "工作簿名称"
    
    Dim flag As Boolean
    Dim pRow As Long
    pRow = 0
    For i = 0 To UBound(RetFiles)
        flag = False
        '避免用Or将多个判断连接在一起，因为那样会每一个判断都执行
        If VBA.InStr(RetFiles(i), ".xls") Then
            flag = True
        ElseIf VBA.InStr(RetFiles(i), ".xls") Then
            flag = True
        ElseIf VBA.InStr(RetFiles(i), ".xlsx") Then
            flag = True
        ElseIf VBA.InStr(RetFiles(i), ".xlsm") Then
            flag = True
        End If
        
        If flag Then
            'pRow记录的是有多少个满足条件的
            pRow = pRow   1
            result(pRow, 0) = pRow
            result(pRow, 1) = RetFiles(i)
            
             '添加超链接
             rngout.Offset(pRow, 1).Hyperlinks.Add rngout.Offset(pRow, 1), RetFiles(i)
        End If
    Next
    
    If pRow Then rngout.Resize(pRow   1, 2).Value = result
    
    Set rngout = Nothing
    Erase result
End Sub

如果是想要创建文件的目录，就不需要中间那些判断是否包含文件后缀就可以。

ScanDir这个函数在创建MyVBA加载宏中已经提到过。

GetFolderPath也和ScanDir一样，放在VBAProject下的同一个文件里，代码：

代码语言：javascript复制

Function GetFolderPath() As String
    Dim myFolder As Object
    Set myFolder = CreateObject("Shell.Application").Browseforfolder(0, "选择文件夹", 0)
    If Not myFolder Is Nothing Then
'        GetFolderPath = myFolder.Items.item.path
        GetFolderPath = myFolder.Self.Path
        If Right(GetFolderPath, 1) <> "" Then GetFolderPath = GetFolderPath & ""
    Else
        GetFolderPath = ""
    End If
    Set myFolder = Nothing
End Function

vba

0 人点赞