สอบถามการบันทึกไฟล์ pdf ไปยังโฟลเดอร์เดียวกับไฟล์ Excel

[thanadul0816]

ผมได้ทำการบันทึก Macro เพื่อบันทึกไฟล์ pdf ไปยังโฟลเดอร์เดียวกับไฟล์ Excel
ผลที่ได้ ได้ตามต้องการแล้วครับ
อยากจะสอบถามเพิ่มเติมครับ ว่า สามารถ ปรับโค้ด VBA ให้สั้นกว่านี้ และไม่ต้องฝากสูตรลงใน Cell
ต้องปรับเป็นแบบไหนครับ

[snasui]

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

Code: Select all

Sub ExportPdf()
'    Range("L5").Select
'    ActiveCell.FormulaR1C1 = "=CELL(""filename"")"
'    Range("L6").Select
'    ActiveCell.FormulaR1C1 = "=MID(CELL(""filename""),FIND(""["",CELL(""filename""))+1,FIND(""]"",CELL(""filename""))-FIND(""["",CELL(""filename""))-1)"
'    Range("L7").Select
'    ActiveCell.FormulaR1C1 = "=MID(CELL(""filename"",R[-1]C),FIND(""]"",CELL(""filename"",R[-1]C))+1,256)"
'    Range("L9").Select
'    ActiveCell.FormulaR1C1 = "=LEFT(R[-4]C,LEN(R[-4]C)-R[-1]C[1])"
'    Range("L10").Select
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    ThisWorkbook.Path & "\" & Range("E2").Value & ".pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Sheets("sheet1").Select
    Range("A1").Select
    ActiveWorkbook.Save
    MsgBox "Finish"
  End Sub

[thanadul0816]

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

Code: Select all

Sub ExportPdf()
'    Range("L5").Select
'    ActiveCell.FormulaR1C1 = "=CELL(""filename"")"
'    Range("L6").Select
'    ActiveCell.FormulaR1C1 = "=MID(CELL(""filename""),FIND(""["",CELL(""filename""))+1,FIND(""]"",CELL(""filename""))-FIND(""["",CELL(""filename""))-1)"
'    Range("L7").Select
'    ActiveCell.FormulaR1C1 = "=MID(CELL(""filename"",R[-1]C),FIND(""]"",CELL(""filename"",R[-1]C))+1,256)"
'    Range("L9").Select
'    ActiveCell.FormulaR1C1 = "=LEFT(R[-4]C,LEN(R[-4]C)-R[-1]C[1])"
'    Range("L10").Select
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    ThisWorkbook.Path & "\" & Range("E2").Value & ".pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Sheets("sheet1").Select
    Range("A1").Select
    ActiveWorkbook.Save
    MsgBox "Finish"
  End Sub

ขอบคุณครับ ได้ผลตามต้องการครับ

** ขอสอบถามเพิ่มเติมครับ ผมได้สร้างโมดูล เพื่อเช็คโฟลเดอร์ และสร้างโฟลเดอร์ใหม่หากไม่มีอยู่
ตามไฟล์แนบ ผมทำแบบนี้ได้หรือไม่
และโค้ดส่วนข้างล่างนี้ จะกำหนดให้ เปลี่ยนไปตามที่อยู่ของไฟล์ excel ได้ไหมครับ
จุดประสงค์คือหากย้ายไฟล์ ไม่ต้องมากำหนดใหม่ ครับ

Code: Select all

MkDir "C:\Users\"
            MkDir "C:\Users\THOMAS-611\"
            MkDir "C:\Users\THOMAS-611\OneDrive\"
            MkDir "C:\Users\THOMAS-611\OneDrive\สูตรExcel\"
            MkDir "C:\Users\THOMAS-611\OneDrive\สูตรExcel\address\" & s
            

[snasui]

กรุณาลองทำแล้วนำปัญหามาถามครับ

[thanadul0816]

กรุณาลองทำแล้วนำปัญหามาถามครับ

ตามไฟล์แนบครับ พอดีลืมแนบไฟล์ที่ทำแล้ว ให้ครับ

[snasui]

กรุณาแจ้งปัญหามาในช่องความเห็นด้วยว่าได้ลองทำแล้วติดปัญหาใดครับ

[thanadul0816]

กรุณาแจ้งปัญหามาในช่องความเห็นด้วยว่าได้ลองทำแล้วติดปัญหาใดครับ

ขอโทษด้วยครับ
คำถามคือ ผมได้สร้างโมดูล เพื่อเช็คโฟลเดอร์ และสร้างโฟลเดอร์ใหม่หากไม่มีอยู่
ตามไฟล์แนบ ต้องปรับโค้ดส่วนนี้ยังไง ถ้าหากว่า ย้ายไฟล์ excel ไปโฟลเดอร์อื่น
แล้วไม่ต้องตามแก้ที่อยู่ในส่วนนี้ ครับ

Code: Select all

 tPath = "C:\Users\THOMAS-611\OneDrive\สูตรExcel\address\" '<== Target path
    For Each s In Sheets("Sheet1").Range("E1")
        If Dir(tPath & s, vbDirectory) = vbNullString Then
            MkDir "C:\Users\"
            MkDir "C:\Users\THOMAS-611\"
            MkDir "C:\Users\THOMAS-611\OneDrive\"
            MkDir "C:\Users\THOMAS-611\OneDrive\สูตรExcel\"
            MkDir "C:\Users\THOMAS-611\OneDrive\สูตรExcel\address\" & s
        End If
        

[snasui]

ตัวอย่างการปรับให้ยืดหยุ่นต่อการเปลี่ยน Path ครับ

Code: Select all

Sub Create()
    Dim tPath As String
    Dim s As Range
    Dim sPath As String
    Dim a As Variant
    Dim b() As Variant
    Dim i As Integer
    Dim p As String
    
    On Error Resume Next
    'sPath = "D:\New Folder\" '<== Source path
    tPath = "C:\Users\THOMAS-611\OneDrive\ÊÙµÃExcel\address\" '<== Target path
    a = VBA.Split(tPath, "\")
    For i = 0 To UBound(a)
        ReDim Preserve b(i)
        b(i) = a(i)
        With Application
            p = VBA.Join(.Transpose(.Transpose(.WorksheetFunction.Index(b, 0))), "\")
        End With
        If Dir(p, vbDirectory) = vbNullString Then
            MkDir p
        End If
    Next i
    
    For Each s In Sheets("Sheet1").Range("E1")
'        If Dir(tPath & s, vbDirectory) = vbNullString Then
'            MkDir "C:\Users\"
'            MkDir "C:\Users\THOMAS-611\"
'            MkDir "C:\Users\THOMAS-611\OneDrive\"
'            MkDir "C:\Users\THOMAS-611\OneDrive\ÊÙµÃExcel\"
'            MkDir "C:\Users\THOMAS-611\OneDrive\ÊÙµÃExcel\address\" & s
'        End If
        FileCopy sPath & s.Offset(0, -3), tPath & s & "\" & s.Offset(0, -3)
    Next s
End Sub

[thanadul0816]

ตัวอย่างการปรับให้ยืดหยุ่นต่อการเปลี่ยน Path ครับ

Code: Select all

Sub Create()
    Dim tPath As String
    Dim s As Range
    Dim sPath As String
    Dim a As Variant
    Dim b() As Variant
    Dim i As Integer
    Dim p As String
    
    On Error Resume Next
    'sPath = "D:\New Folder\" '<== Source path
    tPath = "C:\Users\THOMAS-611\OneDrive\ÊÙµÃExcel\address\" '<== Target path
    a = VBA.Split(tPath, "\")
    For i = 0 To UBound(a)
        ReDim Preserve b(i)
        b(i) = a(i)
        With Application
            p = VBA.Join(.Transpose(.Transpose(.WorksheetFunction.Index(b, 0))), "\")
        End With
        If Dir(p, vbDirectory) = vbNullString Then
            MkDir p
        End If
    Next i
    
    For Each s In Sheets("Sheet1").Range("E1")
'        If Dir(tPath & s, vbDirectory) = vbNullString Then
'            MkDir "C:\Users\"
'            MkDir "C:\Users\THOMAS-611\"
'            MkDir "C:\Users\THOMAS-611\OneDrive\"
'            MkDir "C:\Users\THOMAS-611\OneDrive\ÊÙµÃExcel\"
'            MkDir "C:\Users\THOMAS-611\OneDrive\ÊÙµÃExcel\address\" & s
'        End If
        FileCopy sPath & s.Offset(0, -3), tPath & s & "\" & s.Offset(0, -3)
    Next s
End Sub

ขอบคุณครับ

ผมได้ลองย้ายไฟล์แล้ว เมื่อรันโค้ด เกิด Dedug ตามรูปครับ
ได้ลองเปลี่ยน tPath เป็น = ThisWorkbook.Path แล้วก็ยังไม่ได้ครับ

[snasui]

กรณีต้องการให้เซลล์ E1 เป็น Path ด้วย ควรเขียนเช่นตัวอย่างด้านล่างครับ

Code: Select all

Sub Create()
    Dim tPath As String
    Dim s As Range
    Dim sPath As String
    Dim a As Variant
    Dim b() As Variant
    Dim i As Integer
    Dim p As String
    
    On Error Resume Next
    'sPath = "D:\New Folder\" '<== Source path
    tPath = ThisWorkbook.Path & "\" & Sheets("Sheet1").Range("e1").Value '<== Target path
    'Other code

[thanadul0816]

ได้ผลลัพธ์ตามต้องการแล้วครับ ขอบคุณมากครับ