สอบถาม CodeVB ส่งออกข้อมูลเป็น csv

[tigerwit]

จากไฟล์ที่แนบมา
ต้องการส่งออกข้อมูลใน Sheet1 เป็นไฟล์ csv แต่ส่งออกไม่ได้
แต่โค๊ดเดียวกันนี้ส่งออกข้อมูลใน sheet2 ได้ เข้าใจว่าเป็นเพราะมีการผสานเซล นำให้โค๊ดไม่ทำงาน
จะปรับโค๊ดอย่างไร ให้สามารถส่งออกข้อมูลจาก sheet1 ได้

Code: Select all

Sub ExpCsv()
    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:\" & "Money"
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If
    
    sFolderPath = "C:\" & "Money" & "\" & "Backup"
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If
       
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo Err
    FName = ActiveSheet.Range("A16").Value & ".csv"

    If MsgBox("คุณต้องการส่งออก " & Range("A16").Value & " ใช่หรือไม่ ?", 36, "ยืนยันการส่งออกบันทึกการรับจ่ายเงิน") = 6 Then
    Set myWB = ThisWorkbook
    Set rngToSave = Range("C3:E14,G3:I14,K3:K14")
    rngToSave.Copy
    Set tempWB = Application.Workbooks.Add(1)
    With tempWB
        .Sheets(1).Range("A1").PasteSpecial xlPasteValues
Application.DisplayAlerts = False
.SaveAs Filename:=sFolderPath & "\" & FName, FileFormat:=xlCSV, CreateBackup:=False, local:=True
 .Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
'    MsgBox "ส่งออก" & Range("A18").Value & "ไปไว้ที " & "C:\" & Range("a16").Value & "\" & Range("a17").Value & "\" & "คะแนนสอบ" & "\" & FName
    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:
    End If
        Application.DisplayAlerts = True
        Range("A1").Select
End Sub

[puriwutpokin]

ปรับตรงนี้ดูครับ

Code: Select all

'Other code...
    Set rngToSave = Range("C3:E14,G3:I14,K3:K14")
    rngToSave.UnMerge
    rngToSave.Copy
'Other code...

[tigerwit]

ขอบคุณครับ