VBA根據檔案名字自動建立檔案夾，建立檔案夾，截取檔案名，

Sub test()
    Dim Fso As Object, oFile As Object, allpathfile$, filepath$, sFolder$, t$
    allpathfile = [B1].Value & "\"
    t = [B3].Value
    Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each oFile In Fso.GetFolder(allpathfile).Files
        If oFile.Name Like "*" & "." & t Then
            'creat folder---------------------------
            FolderName = Split(oFile.Name, "_")
            folderpath = allpathfile & FolderName(1)
            If IsFileExists(folderpath) = True Then
            
            Else
            Fso.CreateFolder folderpath
            End If
             '----------------------------------
        End If

        filepath = folderpath & "\"
           'MsgBox Format(Now(), "yyyymmddhhMMss")
        If oFile.Name Like "*" & "." & t Then
            FolderName2 = Split(Split(oFile.Name, "_")(2), ".")
            newfilename = FolderName2(0) & "_" & Format(Now(), "yyyymmdd") & "." & t
            refilepath2 = allpathfile & newfilename
            
            'Name folderpath & "\" & oFile.Name As folderpath & "\" & newfilename
            oFile.Name = newfilename
            sFolder = filepath & Replace(oFile.Name, t, "")
            If Fso.FileExists(filepath & "\" & oFile.Name) Then Fso.DeleteFile sFolder & "\" & oFile.Name
            folderpath2 = folderpath & "\" & FolderName2(0)
            Fso.CreateFolder folderpath2
            newsFolder = Split(newfilename, "_")(0)
            oFile.Move (filepath & newsFolder & "\")
        End If
        
     Next oFile
     Set Fso = Nothing
     Set FolderName = Nothing

End Sub
Function IsFileExists(ByVal folderpath As String) As Boolean
    If Dir(folderpath, 16) <> Empty Then
        IsFileExists = True
    Else
        IsFileExists = False
        End If
End Function