如题所述
Sub Make_Directory()
Dim mypath As Object
Dim rg As range
Dim tempName As String
For Each rg In Sheets("创建路径").range("A1:A5")
tempName = rg.Value
MyMkDir tempName
Next rg
End Sub
Public Sub MyMkDir(sPath As String)
Dim iStart As Integer
Dim aDirs As Variant
Dim sCurDir As String
Dim i As Integer
Dim fileNamePos As Integer
If sPath "" Then
aDirs = Split(sPath, "\")
fileNamePos = InStrRev(sPath, aDirs(3)) '获取文件名所在的位置
If Left(sPath, 2) = "\\" Then
iStart = 3
Else
iStart = 1
End If
sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
For i = iStart To UBound(aDirs)
sCurDir = sCurDir & aDirs(i) & "\"
If Dir(sCurDir, vbDirectory) = vbNullString Then
MkDir sCurDir
End If
copyFile sPath, sCurDir
Next i
End If
End Sub
Sub copyFile(ByRef srcPath As String, ByRef destPath As String)
'这里需要把文件拷贝到创建的目录下
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Call fso.copyFile(srcPath, destPath)
On Error Resume Next
End Sub
只参考第一个sub