Add path VBA

[Jirawat namrach]

รบกวนขอแนวทางปรับแต่ง Code เพื่อก็อปปี้ Path PDF ใน Folder ที่มีคำว่า "REPLACEMENT" เท่านั้นครับ

Code: Select all

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object, sf
    Dim i As Integer, colFolders As New Collection, ws As Worksheet
    
    Set ws = Sheets("Path")
    ws.Range("a1 : a5000").ClearContents
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder("C:\Users\Lenovo\Desktop\PATH")
    
    colFolders.Add oFolder
    
    Do While colFolders.Count > 0
        Set oFolder = colFolders(1)
        colFolders.Remove 1
    
        For Each oFile In oFolder.files
            If Right(oFile, 7) = ".SLDDRW" Then
                ws.Cells(i + 1, 1) = oFolder.Path
                ws.Cells(i + 1, 2) = oFile.Name
                i = i + 1
            End If
        Next oFile


        For Each sf In oFolder.SubFolders
            colFolders.Add sf
        Next sf
    Loop

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'Other code
For Each oFile In oFolder.files
'   If Right(oFile, 7) = ".SLDDRW" Then
    If InStr(oFile, "REPLACEMENT") Then
        ws.Cells(i + 1, 1) = oFolder.Path
        ws.Cells(i + 1, 2) = oFile.Name
        i = i + 1
    End If
Next oFile
'Other code

[Jirawat namrach]

ขอโทษครับอาจารย์ ผมสื่อสารผิดเอง ตัวอย่าง Code ของอาจารย์ ได้ข้อมูลมาทั้งหมดครับ ต้องการแค่ .SLDDRW รบกวนด้วยครับอาจารย์

[snasui]

ยังไม่ค่อยเข้าใจครับ

สิ่งที่เขียนไว้เดิมคือต้องการเฉพาะไฟล์ที่มีคำว่า .SLDDRW ไม่ทราบว่าติดปัญหาส่วนใดและต้องการจะเพิ่มเงื่อนไขใดครับ

ลองดูว่าด้านล่างนี้คือสิ่งที่ต้องการหรือไม่ครับ

Code: Select all

'Other code
For Each oFile In oFolder.Files
    If InStr(oFile, "REPLACEMENT") Then
       If Right(oFile, 7) = ".SLDDRW" Then
            ws.Cells(i + 1, 1) = oFolder.Path
            ws.Cells(i + 1, 2) = oFile.Name
            i = i + 1
       End If
    End If
Next oFile
'Other code

[Jirawat namrach]

ตาม Code ล่าสุด ได้ตามที่ต้องการครับ แต่อยากสอบถามเพิ่ม กรณีนี้เราสามารถระบุเจาะจงเป็น folder ได้หรือเปล่าครับ เพราะลักษณะ Code ที่ใช้งานนี้ มันจะไปค้นหาทุกไฟล์ แล้วมาเปรียบเทียบว่า มี "REPLACEMENT" และนามสกุล ".SLDDRW" หรือไม่ ทำให้การ Process ค่อนข้างนาน เนื่องจากไฟล์มีจำนวนมาก อย่างเช่น สามารถระบุ folder "C:\Users\Lenovo\Desktop\PATH\REPLACEMENT 3000" แล้วค้นหา .SLDDRW เสร็จแล้ว ก็ไป folder ถัดไป "C:\Users\Lenovo\Desktop\PATH\REPLACEMENT 4000" แล้วทำเหมือนกัน แบบนี้สามารถทำได้หรือเปล่าครับ

[snasui]

สามารถระบุ folder "C:\Users\Lenovo\Desktop\PATH\REPLACEMENT 3000" แล้วค้นหา .SLDDRW เสร็จแล้ว ก็ไป folder ถัดไป "C:\Users\Lenovo\Desktop\PATH\REPLACEMENT 4000" แล้วทำเหมือนกัน แบบนี้สามารถทำได้หรือเปล่าครับ

สามารถทำได้โดยเพิ่ม Procedure ขึ้นมา มีหน้าที่ส่งค่า Folder เป้าหมายไปดำเนินการใน Procedure เดิมสำหรับค้นหาไฟล์ ซึ่งต้องแปลงคำสั่งใน Procedure เดิมให้มี Parameter เพื่อรับค่า Folder เข้ามาดำเนินการ และหากมี Folder ที่ต้องส่งไปจัดการจำนวนมากอาจจะต้องเขียนให้ Loop จากค่าที่กำหนดไว้ในชีตหรือไฟล์ใด ๆ ไปใช้งานแทนเขียนเข้าไปตรง ๆ ใน Code

ตัวอย่าง Code เพื่อส่งไปจัดการแค่ 2 Folders ครับ

Code: Select all

Dim i As Long

Sub main()
    i = 0
    Call getpath2("C:\Users\Lenovo\Desktop\PATH\REPLACEMENT 3000")
    Call getpath2("C:\Users\Lenovo\Desktop\PATH\REPLACEMENT 4000")
End Sub

Sub getpath2(f As String)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object, sf
'    Dim i As Integer, colFolders As New Collection, ws As Worksheet
    Dim colFolders As New Collection, ws As Worksheet
    Set ws = Sheets("Path")
'    ws.Range("a1 : a5000").ClearContents
    Set oFSO = CreateObject("Scripting.FileSystemObject")
'    Set oFolder = oFSO.GetFolder("C:\Users\Lenovo\Desktop\PATH")
    Set oFolder = oFSO.GetFolder(f)
    
    
    colFolders.Add oFolder
    
    Do While colFolders.Count > 0
        Set oFolder = colFolders(1)
        colFolders.Remove 1
    
        For Each oFile In oFolder.Files
            If InStr(oFile, "REPLACEMENT") Then
               If Right(oFile, 7) = ".SLDDRW" Then
                    ws.Cells(i + 1, 1) = oFolder.Path
                    ws.Cells(i + 1, 2) = oFile.Name
                    i = i + 1
               End If
            End If
        Next oFile

'        For Each sf In oFolder.SubFolders
'            colFolders.Add sf
'        Next sf
    Loop
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic

End Sub

[Jirawat namrach]

หลังจาก Run Folder แรก และได้ข้อมูลมาแล้ว พอขึ้น Folder ที่สอง ข้อมูลที่ได้มาจะทับข้อมูลเดิมที่มีอยู่ ต้องการให้ข้อมูลจาก Folder ที่สองบันทึกต่อจาก Folder แรก ต้องแก้ไข Code ยังไงครับอาจารย์

[snasui]

Code นั้นไม่ควรที่จะทับข้อมูลเดิม ในเครื่องผมสามารถรันได้ปกติ

ลอง Debug ดูและแก้ Code มาเองดูก่อน ติดแล้วค่อยถามกันต่อครับ

ที่สำคัญ Code ที่ให้ไปจะต้องเอาไปใช้ทุกบรรทัด ลองสังเกตดูว่านำ Code ไปใช้ครบทุกบรรทัดแล้วหรือไม่ครับ

[Jirawat namrach]

ได้แล้วครับอาจารย์ ขอบคุณมากครับ