Macro | สร้าง Folder ใหม่ โดยใช้ Script

[SaturdayAugust™]

สวัสดีครับ คุณคนควน

ผมขอคำแนะนำอีกแล้วครับ ในกรณีที่ผมต้องการเขียน Script ขึ้นมาเพื่อสั่งให้ Excel File ถูกบันทึกลงไปใน Location ที่กำหนด เช่น
ผมส่ง e-mail โดยแนบ Excel File ไปให้ User และให้ User กดปุ่มเพื่อให้ Script ทำการสร้าง Folder ตามตำแหน่งดังนี้ครับ
"D:\Program\Master\File" แล้วจากนั้นก็สั่งให้ Excel File ถูกเก็บบันทึกลงใน Folder ดังกล่าวครับ ต้องทำอย่างไรครับ
ผมได้พยายามทำแล้ว แต่ไม่สำเร็จครับ ได้แต่เพียงว่า จะเอาไปบันทึกเก็บทีไ่หน โดยต้องสร้าง Folder รองรับไว้ก่อนเสมอน่ะครับ

รบกวนด้วยนะครับ

ขอบคุณครับ

[snasui]

ลองตาม Code ด้านล่างครับ

จะเป็นการตรวจสอบว่ามี Folder ที่ต้องการแล้วหรือไม่ ถ้ามีแล้วก็ทำการ Save ไฟล์ในชื่อ Test ถ้ายังไม่มีก็ให้สร้าง Folder ขึ้นมาก่อนแล้วก็ Save ไฟล์ในชื่อ Test

Code: Select all

Option Explicit

Function FolderExist(Path As String) As Boolean
    On Error Resume Next
    If Not Dir(Path, vbDirectory) = vbNullString Then
        FolderExist = True
    End If
    On Error GoTo 0
End Function

Sub TestFolder()
    If FolderExist("D:\Program\Master\File") Then
        ChDir "D:\Program\Master\File"
        ThisWorkbook.SaveAs ("Test.xls") 'Save file name as "Test"
    Else
        MkDir "D:\Program\Master\File"
        ChDir "D:\Program\Master\File"
        ThisWorkbook.SaveAs ("Test.xls") 'Save file name as "Test"
    End If
End Sub

เวลาใช้งานให้เรียกใช้ TestFolder นะครับ

[SaturdayAugust™]

สวัสดีครับ คุณคนควน

ผมเอา Code ไป Run แล้วครับ พบว่ามี error บางประการครับ โดยผมได้แนบ File มาประกอบด้วยครับ

รบกวนนะครับ

ขอบคุณครับ

[snasui]

ลองใช้ Code ตามด้านล่างครับ

เป็นการสร้าง Folder หลักและย่อยตามลำดับ

Code: Select all

Option Explicit
Function FolderExist(Path As String) As Boolean
    On Error Resume Next
    If Not Dir(Path, vbDirectory) = vbNullString Then
        FolderExist = True
    End If
    On Error GoTo 0
End Function

Sub TestFolder()
    If FolderExist("D:\Program\Master\File") Then
        ChDir "D:\Program\Master\File"
        ThisWorkbook.SaveAs ("Test.xls") 'Save file name as "Test"
    Else
    On Error Resume Next
        MkDir "D:\Program\"
        MkDir "D:\Program\Master"
        MkDir "D:\Program\Master\File"
        ChDir "D:\Program\Master\File"
        ThisWorkbook.SaveAs ("Test.xls") 'Save file name as "Test"
    End If
End Sub