VBA模板记录 - 技术栈

VBA模板记录

只会HelloWorld的华娃2025-08-24 15:40

文章目录

路径相关
- 获取当前工作簿路径
文件夹相关
- 复制文件夹下所有内容到另一个文件夹
- 文件夹若存在则删除后新建，否则直接新建
工作簿相关
工作表相关
- 工作表若存在则删除后新建，否则直接新建

路径相关

获取当前工作簿路径

bash 复制代码

Application.ActiveWorkbook.Path '路径本身（不带工作簿名称）
Application.ActiveWorkbook.FullName '用于具有工作簿名称的路径。

文件夹相关

复制文件夹下所有内容到另一个文件夹

bash 复制代码

Sub copy_folder(byval sourceFolder As String, _
byval destinationFolder As String)

    Dim fso As Object
    
    ' 创建 FileSystemObject 对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 调用 CopyFolder 方法进行复制
    On Error Resume Next
    fso.CopyFolder sourceFolder, destinationFolder, True ' True 表示允许覆盖
    If Err.Number <> 0 Then
        MsgBox "复制失败: " & Err.Description, vbExclamation, "错误"
        Err.Clear
    Else
        MsgBox "文件夹复制成功！", vbInformation, "完成"
    End If
    
    ' 释放对象
    Set fso = Nothing
End Sub

文件夹若存在则删除后新建，否则直接新建

bash 复制代码

Sub remove_and_make_folder(byval folder_path as string)
    Dim resFolder
    resFolder = Dir(folder_path, vbDirectory)   '判断路径为"D:\changeAfter_Files"的文件夹是否存在
    '如果不存在，就新建一个
    If resFolder = "" Then
        MkDir folder_path '("D:\changeAfter_Files")
    else
        rmdir folder_path '("D:\changeAfter_Files")
        MkDir folder_path '("D:\changeAfter_Files")
    End If
End Sub

工作簿相关

工作表相关

工作表若存在则删除后新建，否则直接新建

bash 复制代码

Sub remove_and_make_sheet(SheetName As String)
    Dim Exists As Boolean
    With ThisWorkbook
        On Error Resume Next
        Exists = (.Worksheets(SheetName).Name <> "")
        On Error GoTo 0
        If Not Exists Then
            .Sheets.Add After:=.Sheets(.Sheets.Count)
            .Sheets(.Sheets.Count).Name = SheetName
        End If
    End With
End Sub