Code VB ส่งออกข้อมูล

[tigerwit]

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

Code: Select all

Sub ExpDataCol() ' ส่งออกข้อมูลการจัดซื้อทั้งหมด
    Dim sFolderPath As String
    Dim Path As String
    Dim FName As String
    On Error Resume Next
    Application.ScreenUpdating = False
    sFolderPath = "C:\" & "Pasadu"
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If
    FName = "Exp"
    On Error GoTo err
    If MsgBox("คุณต้องการส่งออกข้อมูลการจัดซื้อทั้งหมด ใช่หรือไม่ ?", 36, "ยืนยันการส่งออกข้อมูลการจัดซื้อ") = 6 Then
    Set myWB = ThisWorkbook
    Set rngToSave = Range("B2:I3500")
    rngToSave.Copy
    Set tempWB = Application.Workbooks.Add(1)
    With tempWB
        .Sheets(1).Range("A1").PasteSpecial xlPasteValues
        .SaveAs Filename:=sFolderPath & "\" & FName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, local:=True
        .Close
    MsgBox "ส่งออกไฟล์ไปไว้ที " & sFolderPath & "\" & FName, vbInformation
        ActiveWorkbook.FollowHyperlink Address:=sFolderPath, NewWindow:=True
        Application.ScreenUpdating = True
    End With
err:
    End If
        Application.DisplayAlerts = True
        Range("B2").Select
End Sub

[tigerwit]

ได้แล้วครับ

Code: Select all

Sub ExpDataCol() ' ส่งออกข้อมูลการจัดซื้อทั้งหมด
    Dim sFolderPath As String
    Dim Path As String
    Dim FName As String
    On Error Resume Next
    Application.ScreenUpdating = False
    sFolderPath = "C:\" & "Pasadu"
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If
    FName = "Exp"
    On Error GoTo err
    If MsgBox("คุณต้องการส่งออกข้อมูลการจัดซื้อทั้งหมด ใช่หรือไม่ ?", 36, "ยืนยันการส่งออกข้อมูลการจัดซื้อ") = 6 Then
    Set myWB = ThisWorkbook
    Set rngToSave = Range("B2:I3500")
    rngToSave.Copy
    Set tempWB = Application.Workbooks.Add(1)
   Application.DisplayAlerts = false
    With tempWB
        .Sheets(1).Range("A1").PasteSpecial xlPasteValues
        .SaveAs Filename:=sFolderPath & "\" & FName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, local:=True
        .Close
    MsgBox "ส่งออกไฟล์ไปไว้ที " & sFolderPath & "\" & FName, vbInformation
        ActiveWorkbook.FollowHyperlink Address:=sFolderPath, NewWindow:=True
        Application.ScreenUpdating = True
    End With
err:
    End If

        Range("B2").Select
End Sub