Snasui Excel Forum

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

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