麻辣家族討論版版 - Powered by Discuz! Board

Sub ex()
Set fdo = CreateObject("Scripting.FileSystemObject")
fd = "C:\Documents and Settings\User\桌面\" '桌面路徑
Set a = Columns("A").Find([B1], lookat:=xlWhole)
If Not a Is Nothing Then
fs = fd & Join(Application.Transpose(Application.Transpose(a.Offset(, 1).Resize(, 3))), "-") & "-" & Format(Date, "yyyymmdd") & "\"
If fdo.folderexists(fs) = False Then MkDir fs
End If
End Sub

複製代碼

Option Explicit
Sub 建立()
Dim Rng As Range, xF As Variant, xlDesktop As String
Set Rng = Range("A7:A" & [A7].End(xlDown).Row)
Set xF = Rng.Find([b1], lookat:=xlWhole)
If xF Is Nothing Then Exit Sub
xF = Application.Transpose(Application.Transpose(Cells(xF.Row, "a").Resize(, 3).Value))
xF = Join(xF, "-") & "-" & Format(Date, "yymmdd")
xlDesktop = Get_Desktop
If Dir(xlDesktop & xF, 16) = "" Then MkDir (xlDesktop & xF) '
End Sub
Sub 全選()
Dim E As Range, xF As Variant, xlDesktop As String
xlDesktop = Get_Desktop
For Each E In Range("A7:A" & [A7].End(xlDown).Row)
xF = Application.Transpose(Application.Transpose(Cells(E.Row, "a").Resize(, 3).Value))
xF = Join(xF, "-") & "-" & Format(Date, "yymmdd")
If Dir(xlDesktop & xF, 16) = "" Then MkDir (xlDesktop & xF)
Next
End Sub
Private Function Get_Desktop() As String '函數 : 傳回所在電腦的桌面路徑
Dim ob As Object
Set ob = CreateObject("Wscript.Shell")
Get_Desktop = ob.SpecialFolders("Desktop") & "\"
End Function

複製代碼