Snasui Excel Forum

:D ในขั้นตอน Save ลองเปลี่ยนจาก [c]FileFormat:=xlCSVUTF8[/c] เป็น [c]FileFormat:=xlCSV[/c] ครับ

Sub ExpGToTeach()
    
    Dim Wb As Worksheet
    Dim myCSVFileName As String
    Dim myWB As Workbook
    Dim tempWB As Workbook
    Dim rngToSave As Range
    
    Dim sFolderPath As String
    Dim Path As String
    Dim FName As String
'    On Error Resume Next

    sFolderPath = "C:\" & Range("A17").Value
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If
    
    sFolderPath = "C:\" & Range("A17").Value & "\" & Range("A18").Value
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If
    
    sFolderPath = "C:\" & Range("A17").Value & "\" & Range("A18").Value & "\" & "Grade"
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo err
    FName = ActiveSheet.Range("A22") & " " & ActiveSheet.Range("A23") & ActiveSheet.Range("A224") & ".csv"

    Sheet2.Activate
    Set myWB = ThisWorkbook
    Set rngToSave = Range("E3:J48")
    rngToSave.Copy
    Set tempWB = Application.Workbooks.Add(1)
    With tempWB
        .Sheets(1).Range("A1").PasteSpecial xlPasteValues
Application.DisplayAlerts = False
.SaveAs Filename:=sFolderPath & "\" & FName, FileFormat:=xlCSVUTF8, CreateBackup:=False, local:=True
 .Close
 Sheet1.Activate
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
        If MsgBox("ส่งออกไฟล์ชื่อ " & FName & vbCrLf & "ไปไว้ที " & sFolderPath & " เรียบร้อยแล้ว" _
        & vbCrLf & "ต้องการเปิด Folder กด Yes ไม่ต้องการ กด No ", 36, "Open Folder") = 6 Then
        ActiveWorkbook.FollowHyperlink Address:=sFolderPath, NewWindow:=True
    End If

    End With
err:
        Application.DisplayAlerts = True
        Range("E5").Select
End Sub

จากไฟล์ที่แนบมา
[code]
Sub ExpGToTeach()

Dim Wb As Worksheet
Dim myCSVFileName As String
Dim myWB As Workbook
Dim tempWB As Workbook
Dim rngToSave As Range

Dim sFolderPath As String
Dim Path As String
Dim FName As String
' On Error Resume Next

sFolderPath = "C:\" & Range("A17").Value
If Dir(sFolderPath, vbDirectory) = "" Then
MkDir sFolderPath
End If

sFolderPath = "C:\" & Range("A17").Value & "\" & Range("A18").Value
If Dir(sFolderPath, vbDirectory) = "" Then
MkDir sFolderPath
End If

sFolderPath = "C:\" & Range("A17").Value & "\" & Range("A18").Value & "\" & "Grade"
If Dir(sFolderPath, vbDirectory) = "" Then
MkDir sFolderPath
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo err
FName = ActiveSheet.Range("A22") & " " & ActiveSheet.Range("A23") & ActiveSheet.Range("A224") & ".csv"

Sheet2.Activate
Set myWB = ThisWorkbook
Set rngToSave = Range("E3:J48")
rngToSave.Copy
Set tempWB = Application.Workbooks.Add(1)
With tempWB
.Sheets(1).Range("A1").PasteSpecial xlPasteValues
Application.DisplayAlerts = False
.SaveAs Filename:=sFolderPath & "\" & FName, FileFormat:=xlCSVUTF8, CreateBackup:=False, local:=True
.Close
Sheet1.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If MsgBox("ส่งออกไฟล์ชื่อ " & FName & vbCrLf & "ไปไว้ที " & sFolderPath & " เรียบร้อยแล้ว" _
& vbCrLf & "ต้องการเปิด Folder กด Yes ไม่ต้องการ กด No ", 36, "Open Folder") = 6 Then
ActiveWorkbook.FollowHyperlink Address:=sFolderPath, NewWindow:=True
End If

End With
err:
Application.DisplayAlerts = True
Range("E5").Select
End Sub

[/code]

ใช้ส่งออกไฟล์เป็น csv การจากทดลองใน excel 2016 สามารถทำงานได้ปกติ ส่งออกไฟล์ไปโฟลเดอร์ที่สร้างขึ้นมาได้
แต่นำไปใช้กับ excel 2010 จะมีปัญหาในขั้นตอนของการเซฟไฟล์ ตั้งชื่อไฟล์
จะปรับอย่างไรให้สามารถทำงานได้ตั้งแต่ excel 2010 ขึ้นไป