Excel Forum

Code: Select all

Sub ExpGPA()
    Dim sFolderPath As String
    Dim wb1 As Workbook
    Dim ws1 As Worksheet
    Dim wb2 As Workbook
    Dim Path As String
    Dim FName As String
'    Dim FileSaveName As Variant
'    FileSaveName = Application.GetSaveAsFilename(InitialFileName:=ActiveWorkbook.Name, FileFilter:="Excel 2003 (*.xls), *.xls")
    On Error Resume Next
    Application.ScreenUpdating = False
    sFolderPath = "C:\" & Range("J1").Value
        If Dir(sFolderPath, vbDirectory) = "" Then
            MkDir sFolderPath
        End If
    sFolderPath = "C:\" & Range("J1").Value & "\" & "LocalSchool"
        If Dir(sFolderPath, vbDirectory) = "" Then
            MkDir sFolderPath
        End If
    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Sheets("Grade")
    
    FName = ws1.Range("K1")
    ws1.Range("A:G").Copy
    Set wb2 = Workbooks.Add
    With wb2.ActiveSheet.Range("A:G")
        .PasteSpecial (xlValues)
        .PasteSpecial (xlFormats)
    Range("A2").Select
    Application.DisplayAlerts = True
    End With
    Application.DisplayAlerts = False
    wb2.SaveAs Filename:=sFolderPath & "\" & FName, FileFormat:=56
    Application.CutCopyMode = False
    wb2.Close
    Application.ScreenUpdating = True
            If MsgBox("ส่งออกไฟล์ชื่อ " & FName & vbCrLf & "ไปไว้ที " & "C:\" & Range("J1").Value & "\" & "LocalSchool" _
            & " เรียบร้อยแล้ว" & vbCrLf & "ต้องการเปิด Folder กด Yes ไม่ต้องการ กด No ", 36, "Open Folder") = 6 Then
            ActiveWorkbook.FollowHyperlink Address:=sFolderPath, NewWindow:=True
        End If
End Sub