ต้องการคำสั่งที่สร้าง Folder ในไดร์ตามข้อมูลใน excel

[widtara]

ต้องการคำสั่งที่สร้าง Folder ในไดร์ตามข้อมูลใน excel อัตโนมัติ เช่น
ที่ A1:A15 มีข้อมูลแบบนี้อยู่แล้วอยากได้คำสั่งที่สั่งแล้วสามารถสร้าง Folder ใหม่โดยตั้งตามชื่อ ใน A1:A15 โดยจะได้ 15 Folder ลักษณะแบบนี้สามารถทำได้ไหมค่ะ ช่วยแนะนำหน่อยค่ะว่าต้องทำอย่างไร
A1:A5
RJN-T1144-01-01
QAN-F1144-02-01
RJN-F1144-01-02
QAN-F1145-01-01
RJN-F1145-01-01
QAN-T1140-03-01
QAN-T1140-02-01
RJN-F1140-01-01
QAN-F1140-01-01
QAN-F1140-02-01
QAN-F1140-03-01
QAN-T1140-04-03
QAN-T1140-04-02
QAN-T1140-04-01
QAN-F1140-04-01

[widtara]

ข้อมูลภาพเพิ่มเติมค่ะ

[snasui]

ดูตัวอย่างการสร้าง Folder ที่นี่ครับ http://snasui.blogspot.com/2011/01/folder-vba.html

[widtara]

ดูตัวอย่างการสร้าง Folder ที่นี่ครับ http://snasui.blogspot.com/2011/01/folder-vba.html

อาจารย์ค่ะ ลองทำแล้วยัง งงๆ อยู่ค่ะ รันดูแล้วมันไม่ขยับทำอะไรเลย ช่วยเช็คดูให้หน่อยค่ะ
แล้วคำสั่งไหนค่ะที่มันอ่านข้อมูลใน excel แล้วไปสร้างเป็น Folder ค่ะ มีไฟล์มาให้ดูค่ะ
หนูลองเอาโค้ดมาดัดแปลงใช้ เปลี่ยน D: เป็น R: ค่ะ

[snasui]

แล้วคำสั่งไหนค่ะที่มันอ่านข้อมูลใน excel แล้วไปสร้างเป็น Folder

ต้องเขียนเข้าไปเองครับ Code ที่ส่ง Link ให้ไปนั้นเป็นตัวอย่างการตรวจสอบว่ามี Folder อยู่แล้วหรือไม่ ถ้าไม่มีก็ให้สร้างขึ้นมา การนำไปใช้ต้องประยุกต์เพิ่มเข้าไปตามลักษณะของงานจริง ไม่ได้มุ่งหมายให้นำไปใช้ตรง ๆ แต่อย่างใดครับ

ด้านล่างนี้ผมปรับ 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()
    Dim sDir As String
    Dim rng As Range
    If FolderExist("R:\SQA SupplierImprovementPjt\History Parts Quality Project\WORKING PROFILE\Pic Input NCR IQC\") Then
        ChDir "R:\SQA SupplierImprovementPjt\History Parts Quality Project\WORKING PROFILE\Pic Input NCR IQC\"
'        ThisWorkbook.SaveAs ("Test.xls") 'Save file name as "Test"
    Else
    On Error Resume Next
        MkDir "R:\SQA SupplierImprovementPjt\"
        MkDir "R:\SQA SupplierImprovementPjt\History Parts Quality Project\"
        MkDir "R:\SQA SupplierImprovementPjt\History Parts Quality Project\WORKING PROFILE\"
        MkDir "R:\SQA SupplierImprovementPjt\History Parts Quality Project\WORKING PROFILE\Pic Input NCR IQC\"
    End If
        sDir = "R:\SQA SupplierImprovementPjt\History Parts Quality Project\WORKING PROFILE\Pic Input NCR IQC\"
    For Each rng In Sheets("Sheet1").Range("A1:A15")
        MkDir sDir & rng
    Next rng
'    ChDir "R:\SQA SupplierImprovementPjt\History Parts Quality Project\WORKING PROFILE\Pic Input NCR IQC\RJN-T1144-01-01"
'    ThisWorkbook.SaveAs ("Test.xls") 'Save file name as "Test"
End Sub

[widtara]

อาจารย์ค่ะ มันติด Error MkDir sDir & rng ค่ะต้องแก้ตรงไหนค่ะ

[widtara]

ภาพค่ะ

[snasui]

ผม Run ได้เป็นปกติ ตามภาพผลลัพธ์ด้านล่างครับ หากมีการสร้าง Folder ไว้แล้วลองลบทิ้งไปก่อนแล้ว Run Code ใหม่ครับ

[widtara]

ผม Run ได้เป็นปกติ ตามภาพผลลัพธ์ด้านล่างครับ หากมีการสร้าง Folder ไว้แล้วลองลบทิ้งไปก่อนแล้ว Run Code ใหม่ครับ

ได้แล้วค่ะ ขอบพระคุณมากเลย ทำงานสบายขึ้นมากเลยค่ะ ส่งภาพผลงานมาให้ดูค่ะ