Save file tự động không làm mất định dạng của Sheet được copy

[peternhp29]

Thân chào ACE GPE,

Em có tìm được code của một thầy trên GPE và đã sử dụng được với file của em, nhưng có một vấn đề xảy ra ở đây là sau khi file được save, mở file lên thì định dạng không giống như sheet gốc là sheet UL.BM.027

Đoạn code em sưu tầm được của thầy:
Sub GPE()
Dim sh As Worksheet, wb As Workbook, sPath As String
sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
If FileExists(sPath & "\" & [D7] & [H7] & ".xlsx") Then
MsgBox "tep tin da ton tai"
Exit Sub
End If
Set sh = ThisWorkbook.Sheets("UL.BM.027")
Workbooks.Add
Set wb = ActiveWorkbook
sh.UsedRange.Copy wb.Worksheets(1).Range("A1")
wb.Close True, sPath & "\ " & [D7] & [H7] & ".xlsx"
MsgBox "Da luu file xong!"
End Sub
Private Function FileExists(fname) As Boolean
' Returns TRUE if the file exists
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True _
Else FileExists = False
End Function

Cảm ơn ACE GPE đã dành thời gian đọc qua bài này

 

[be_09]

Thân chào ACE GPE,

Em có tìm được code của một thầy trên GPE và đã sử dụng được với file của em, nhưng có một vấn đề xảy ra ở đây là sau khi file được save, mở file lên thì định dạng không giống như sheet gốc là sheet UL.BM.027

Đoạn code em sưu tầm được của thầy:
Sub GPE()
Dim sh As Worksheet, wb As Workbook, sPath As String
sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
If FileExists(sPath & "\" & [D7] & [H7] & ".xlsx") Then
MsgBox "tep tin da ton tai"
Exit Sub
End If
Set sh = ThisWorkbook.Sheets("UL.BM.027")
Workbooks.Add
Set wb = ActiveWorkbook
sh.UsedRange.Copy wb.Worksheets(1).Range("A1")
wb.Close True, sPath & "\ " & [D7] & [H7] & ".xlsx"
MsgBox "Da luu file xong!"
End Sub
Private Function FileExists(fname) As Boolean
' Returns TRUE if the file exists
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True _
Else FileExists = False
End Function

Cảm ơn ACE GPE đã dành thời gian đọc qua bài này

Thử code sau:
Lưu ý:
- DIEN_2018 (là tên Folder nơi ổ D)
- A1 là nơi đặt tên File

Sub LuuTenFile_VoiTenCell()
    Dim TenFile As String
    Dim NoiLuu As String

    Application.DisplayAlerts = False
    NoiLuu = "D:\DIEN_2018\"
    TenFile = Range("A1").Value & ".xlsx"
    ActiveWorkbook.SaveAs NoiLuu & TenFile , xlOpenXMLWorkbook
    Application.DisplayAlerts = True
End Sub

 

[peternhp29]

Thử code sau:
Lưu ý:
- DIEN_2018 (là tên Folder nơi ổ D)
- A1 là nơi đặt tên File

Sub LuuTenFile_VoiTenCell()
    Dim strFilename As String
    Dim strpath As String
    Application.DisplayAlerts = False
   
    strpath = "D:\DIEN_2018\"
    strFilename = Range("A1").Value & ".xlsx"
    ActiveWorkbook.SaveAs strpath & strFilename, xlOpenXMLWorkbook
    Application.DisplayAlerts = True
End Sub

Em cảm ơn thầy/anh đã giúp đỡ em.
Quy trình của em là như thế này, sau khi xuất dữ liệu xong, em sẽ copy rồi paste sheet UL.BM.027 qua một workbook mới rồi save workbook này với tên file là 1 cell trong file (Vd: A1).
Đoạn code em sưu tầm được làm theo đúng ý em muốn nhưng lúc mở file sau khi save thì bị mất định đạng.
Vì mới tìm hiểu nên em đọc code chưa hiểu lắm.
Chúc sức khỏe mọi người.

 

[Ba Tê]

Quy trình của em là như thế này, sau khi xuất dữ liệu xong, em sẽ copy rồi paste sheet UL.BM.027 qua một workbook mới rồi save workbook này với tên file là 1 cell trong file (Vd: A1).

Vì file của bạn là .xls nên muốn không thay đổi định dạng thì cũng phải tạo file mới kiểu .xls
Nhập tên file muốn tạo mới vào ô J1.
Chạy Sub này trong file "UL ...dài tho---òng" của bạn thử xem.
Tất cả lỗi có thể xảy ra, bạn tự quyết.

Sub LuuThanhWb()
Dim MyWbName As String, NewWbName As String, Pat As String
MyWbName = ThisWorkbook.Name
NewWbName = Range("J1").Value
Pat = ThisWorkbook.Path & "\"
    Sheets("UL.BM.027").Copy
    ActiveWorkbook.SaveAs Filename:=Pat & NewWbName, FileFormat:= _
        xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
    ActiveWorkbook.Close False
    Windows(MyWbName).Activate
MsgBox "Da Luu Xong " & Pat & NewWbName & ".xls"
End Sub

 

[peternhp29]

Vì file của bạn là .xls nên muốn không thay đổi định dạng thì cũng phải tạo file mới kiểu .xls
Nhập tên file muốn tạo mới vào ô J1.
Chạy Sub này trong file "UL ...dài tho---òng" của bạn thử xem.
Tất cả lỗi có thể xảy ra, bạn tự quyết.

Sub LuuThanhWb()
Dim MyWbName As String, NewWbName As String, Pat As String
MyWbName = ThisWorkbook.Name
NewWbName = Range("J1").Value
Pat = ThisWorkbook.Path & "\"
    Sheets("UL.BM.027").Copy
    ActiveWorkbook.SaveAs Filename:=Pat & NewWbName, FileFormat:= _
        xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
    ActiveWorkbook.Close False
    Windows(MyWbName).Activate
MsgBox "Da Luu Xong " & Pat & NewWbName & ".xls"
End Sub

Em cảm ơn thầy,

Code của thầy chạy đúng ý của em rồi. Em cảm ơn thầy và mọi người nhiều lắm.