code VBA บันทึกไฟล์เป็นชื่อของไฟล์ที่เปิดขึ้นมาแก้ไข

[tigerwit]

จากไฟล์ที่แนบมา

Code: Select all

Sub SaveTabName()
    Dim Wb As Worksheet
'    Dim myWB As Workbook
'    Dim tempWB As Workbook
    Dim fdObj As Object
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    fdObj.CreateFolder ("C:\" & Range("A1").Value)
    sFolderPath = "C:\" & Range("A1").Value
    FName = ActiveSheet.Range("A2") & ".xlsx"
'    FName = OpenBook.Name
    
    FileToOpen = Application.GetOpenFilename(Title:="เลือกไฟล์ที่จะทำการปรับปรุง", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen <> False Then
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
    Edit_Table
    ActiveWorkbook.SaveAs FileName:=sFolderPath & "\" & FName, FileFormat:=51, CreateBackup:=False, local:=True
    ActiveWorkbook.Close
    MsgBox "Save Flie ไปไว้ที่  " & sFolderPath & "\" & FName
    ActiveWorkbook.FollowHyperlink Address:=sFolderPath, NewWindow:=True
        End If
    Exit Sub

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

เมื่อเปิดไฟล์ .xls ขึ้นมาแก้ไขตาม โค๊ดด้านบนแล้ว ต้องการ SaveAs เป็นไฟล์ .xlsx แต่ยังคงใช้ชื่อเดิมของไฟล์ที่เปิดมาแก้ไข
ต้องปรับ Code อย่างไรครับ

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub SaveTabName()
    Dim Wb As Worksheet
'    Dim myWB As Workbook
'    Dim tempWB As Workbook
    Dim fdObj As Object
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set fdObj = CreateObject("Scripting.FileSystemObject")

    If Dir("C:\" & Range("A1").Value, vbDirectory) = "" Then
        fdObj.CreateFolder ("C:\" & Range("A1").Value)
    End If
    sFolderPath = "C:\" & Range("A1").Value

    sFolderPath = "d:\" & Range("A1").Value
    FName = ActiveSheet.Range("A2") & ".xlsx"
'    FName = OpenBook.Name
    
    FileToOpen = Application.GetOpenFilename(Title:="เลือกไฟล์ที่จะทำการปรับปรุง", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen <> False Then
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
        Edit_Table
        OpenBook.SaveAs Filename:=sFolderPath & "\" & FName, FileFormat:=51, CreateBackup:=False, local:=True
        OpenBook.Close
        MsgBox "Save Flie ไปไว้ที่  " & sFolderPath & "\" & FName
        ThisWorkbook.FollowHyperlink Address:=sFolderPath, NewWindow:=True
    End If
'    Exit Sub

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

การกำหนดให้ DisplayAlerts เป็น False จะต้องเปิดกลับมาให้ใช้งานโดยกำหนดให้เป็น True เสียก่อนที่จะ Exit Sub ไม่เช่นนั้นโปรแกรมจะไม่มีการฟ้องในสิ่งที่ควรฟ้องครับ