常用代码归集

jsgj2023

Sub 复制指定目标位置的文件夹()
    Dim myfolder As String
    Dim newfolder As String
    Dim fso As Scripting.FileSystemObject
    myfolder = ThisWorkbook.Path & "\Adele"
    newfolder = ThisWorkbook.Path & "\lfy\"
    Set fso = New Scripting.FileSystemObject
    If fso.FolderExists(myfolder) = True Then
        fso.CopyFolder myfolder, newfolder, overwritefiles:=True
        MsgBox "文件夹" & myfolder & "连同文件一起被复制了!"
    Else
        MsgBox "文件夹" & myfolder & "不存在,无法复制!"
    End If
    Set fso = Nothing
End Sub

jsgj2023

Sub 判断指定的文件夹是否存在()
Dim myfolder As String
Dim fso As Scripting.FileSystemObject
myfolder = ThisWorkbook.Path & "\Adele"
Set fso = New Scripting.FileSystemObject
If fso.FolderExists(myfolder) = True Then
    MsgBox "文件夹" & myfolder & "存在"
Else
    MsgBox "文件夹" & myfolder & "不存在"
End If
Set fso = Nothing
End Sub

jsgj2023

Sub 提取指定文件夹下所有工作簿的名称()
    Dim fso As Scripting.FileSystemObject
    Dim myfile As Scripting.File
    Dim mypath As String
    Dim i  As Long
    mypath = ThisWorkbook.Path
    Set fso = New Scripting.FileSystemObject
    i = 1
    For Each myfile In fso.GetFolder(mypath).Files
        Cells(i, 1) = myfile.Name
        i = i + 1
    Next
    Set fso = Nothing
End Sub

jsgj2023

Sub 判断当前工作簿所在的驱动器()
Dim fso  As Scripting.FileSystemObject
Dim myfile As String
myfile = ThisWorkbook.FullName
Set fso = New Scripting.FileSystemObject
MsgBox "该文件所在的驱动器名为:" & fso.GetDriveName(myfile)
Set fso = Nothing
End Sub

jsgj2023

Sub 获取指定的文件所在的文件夹名称()
    Dim fso  As Scripting.FileSystemObject
    Dim myfile As String
    myfile = ThisWorkbook.FullName
    Set fso = New Scripting.FileSystemObject
    MsgBox "该文件所在的文件夹名为:" & fso.GetParentFolderName(myfile)
    Set fso = Nothing
End Sub

jsgj2023

Sub 获取当前工作簿的全名()
Dim fso  As Scripting.FileSystemObject
Dim myfile As String
myfile = ThisWorkbook.FullName
Set fso = New Scripting.FileSystemObject
MsgBox "该文件的全名为:" & fso.GetFileName(myfile)
Set fso = Nothing
End Sub

jsgj2023

Sub 获取指定工作簿的扩展名()
Dim fso  As Scripting.FileSystemObject
Dim myfile As String
myfile = ThisWorkbook.FullName
Set fso = New Scripting.FileSystemObject
MsgBox "该文件的扩展名为:" & fso.GetExtensionName(myfile)
Set fso = Nothing
End Sub

jsgj2023

Sub 获取指定工作簿的基础名()
Dim fso As Scripting.FileSystemObject
Dim myfile As String
myfile = ThisWorkbook.Path & "\Adele.xls"
Set fso = New Scripting.FileSystemObject
MsgBox "该文件的基础名称为:" & fso.GetBaseName(myfile)
Set fso = Nothing
End Sub

jsgj2023

Sub 跳转至指定的单元格()
    With Worksheets(1)
        .Hyperlinks.Add anchor:=Range("a1"), Address:="", SubAddress:="Sheet2!A2", _
        ScreenTip:="sheet2", TextToDisplay:="指向Sheet2工作表A2单元格"
    End With
End Sub

heng2131

感谢分享，留个印记。