Xin đoạn code để xuất file, đặt tên theo định dạng thời gian

[marcosheath479]

Xin chào mọi người,

Mình có một file gồm nhiều sheet, trong mỗi sheet đều có công thức. Mọi người cho mình xin đoạn code để có thể xuất file này dưới dạng Value (giống như mình copy toàn bộ file, sang file mới và Paste as Value), file lưu ở ổ đĩa D, tên đặt theo định dạng thời gian của lúc xuất: TK-[năm]-[tháng]-[ngày]-[giờ]-[phút]-[giây].xlsx

Cám ơn mọi người đã đọc bài. Chúc mọi người một ngày tốt lành.

 

[Ngày mai trời lại sáng]

Xin chào mọi người,

Mình có một file gồm nhiều sheet, trong mỗi sheet đều có công thức. Mọi người cho mình xin đoạn code để có thể xuất file này dưới dạng Value (giống như mình copy toàn bộ file, sang file mới và Paste as Value), file lưu ở ổ đĩa D, tên đặt theo định dạng thời gian của lúc xuất: TK-[năm]-[tháng]-[ngày]-[giờ]-[phút]-[giây].xlsx

Cám ơn mọi người đã đọc bài. Chúc mọi người một ngày tốt lành.

Bạn thử chạy sub test

Sub test()
    Dim book As Workbook, newBook As Workbook, sheet As Worksheet
    Set book = ThisWorkbook
    Set sheet = book.Worksheets("KH MAY RIENG")
    Set newBook = SheetToBook(book, sheet)
End Sub

Public Function SheetToBook(ByVal sourceBook As Workbook, ByVal sheetCopy As Worksheet) As Workbook
    Dim saveLocation As String, sFileName As String
    saveLocation = sourceBook.Path
    sFileName = Format(Now, "yyyymmddhhmmss") & ".xlsx"
    sheetCopy.Copy
    Set SheetToBook = ActiveWorkbook
    sFileName = saveLocation & "\" & sFileName
    SheetToBook.SaveAs FileFormat:=xlOpenXMLWorkbook, Filename:=sFileName
End Function

 

[marcosheath479]

Bạn thử chạy sub test

Sub test()
    Dim book As Workbook, newBook As Workbook, sheet As Worksheet
    Set book = ThisWorkbook
    Set sheet = book.Worksheets("KH MAY RIENG")
    Set newBook = SheetToBook(book, sheet)
End Sub

Public Function SheetToBook(ByVal sourceBook As Workbook, ByVal sheetCopy As Worksheet) As Workbook
    Dim saveLocation As String, sFileName As String
    saveLocation = sourceBook.Path
    sFileName = Format(Now, "yyyymmddhhmmss") & ".xlsx"
    sheetCopy.Copy
    Set SheetToBook = ActiveWorkbook
    sFileName = saveLocation & "\" & sFileName
    SheetToBook.SaveAs FileFormat:=xlOpenXMLWorkbook, Filename:=sFileName
End Function

Chào bạn,
Mình cám ơn bạn đã hỗ trợ, mình đã chạy thử và sub chỉ lưu sheet KH MAY RIENG thành file mới. Ý mình là file này có bao nhiêu sheet (vì trong tương lai sẽ có thể thêm vài sheet thông tin nữa , thì sẽ LƯU HẾT vào file mới (lưu dưới dạng value).

 

[BuiQuangThuan]

Chào bạn,
Mình cám ơn bạn đã hỗ trợ, mình đã chạy thử và sub chỉ lưu sheet KH MAY RIENG thành file mới. Ý mình là file này có bao nhiêu sheet (vì trong tương lai sẽ có thể thêm vài sheet thông tin nữa , thì sẽ LƯU HẾT vào file mới (lưu dưới dạng value).

Duyệt qua từng sheet nữa là được

 

[Ngày mai trời lại sáng]

Chào bạn,
Mình cám ơn bạn đã hỗ trợ, mình đã chạy thử và sub chỉ lưu sheet KH MAY RIENG thành file mới. Ý mình là file này có bao nhiêu sheet (vì trong tương lai sẽ có thể thêm vài sheet thông tin nữa , thì sẽ LƯU HẾT vào file mới (lưu dưới dạng value).

Bạn thử tiếp:

Sub test()
    Dim book As Workbook, newBook As Workbook, sheet As Worksheet
    Dim index As Integer
    Set book = ThisWorkbook
    For Each sheet In book.Worksheets
        index = index + 1
        Set newBook = SheetToBook(book, sheet, index)
    Next sheet
End Sub

Public Function SheetToBook(ByVal sourceBook As Workbook, _
    ByVal sheetCopy As Worksheet, ByVal index As Integer) As Workbook
    Dim saveLocation As String, sFileName As String
    saveLocation = sourceBook.Path
    sFileName = index & Format(Now, "yyyymmddhhmmss") & ".xlsx"
    sheetCopy.Copy
    Set SheetToBook = ActiveWorkbook
    sFileName = saveLocation & "\" & sFileName
    SheetToBook.SaveAs FileFormat:=xlOpenXMLWorkbook, Filename:=sFileName
End Function

 

[Ngày mai trời lại sáng]

Chào bạn,
Mình cám ơn bạn đã hỗ trợ, mình đã chạy thử và sub chỉ lưu sheet KH MAY RIENG thành file mới. Ý mình là file này có bao nhiêu sheet (vì trong tương lai sẽ có thể thêm vài sheet thông tin nữa , thì sẽ LƯU HẾT vào file mới (lưu dưới dạng value).

Thêm cái lựa chọn lưu dưới dạng Value hay là không:

Sub test()
    Dim book As Workbook, newBook As Workbook, sheet As Worksheet, index As Integer, blSaveValue As Boolean
    blSaveValue = True '----> Luu duoi dang Value:True/False
    Set book = ThisWorkbook
    For Each sheet In book.Worksheets
        index = sheet.index
        Set newBook = SheetToBook(book, sheet, index, blSaveValue)
    Next sheet
End Sub
Public Function SheetToBook(ByVal sourceBook As Workbook, ByVal sheetCopy As Worksheet, ByVal index As Integer, _
    Optional ByVal blSaeValue As Boolean = False) As Workbook
    Dim saveLocation As String, sFileName As String, sheetNew As Worksheet
    saveLocation = sourceBook.Path
    sFileName = index & Format(Now, "yyyymmddhhmmss") & ".xlsx"
    sheetCopy.Copy
    Set SheetToBook = ActiveWorkbook
    Set sheetNew = SheetToBook.ActiveSheet
    If blSaeValue = True Then
        sheetNew.Cells.Copy
        sheetNew.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
        deleteNameAndShape SheetToBook, sheetNew
        BreakLinks SheetToBook, sourceBook.Name
    End If
    sFileName = saveLocation & "\" & sFileName
    SheetToBook.SaveAs FileFormat:=xlOpenXMLWorkbook, Filename:=sFileName
    SheetToBook.Close
End Function
Public Sub deleteNameAndShape(ByVal book As Workbook, ByVal sheet As Worksheet)
    Dim na As Name, sha As Shape
    On Error Resume Next
    For Each sha In sheet.Shapes
        sha.Delete
    Next sha
    For Each na In book.Names
        na.Visible = True
        na.Delete
    Next na
    On Error GoTo 0
End Sub
Public Sub BreakLinks(ByVal bookNew As Workbook, ByVal bookName As String)
    Dim arrLinks, i As Long
    arrLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
    If Not IsEmpty(arrLinks) Then
        For i = LBound(arrLinks) To UBound(arrLinks)
            If InStr(1, arrLinks(i), "\" & bookName, vbTextCompare) > 0 Then bookNew.BreakLink arrLinks(i), xlLinkTypeExcelLinks
        Next i
    End If
End Sub

 

[Lequocvan]

Xin chào mọi người,

Mình có một file gồm nhiều sheet, trong mỗi sheet đều có công thức. Mọi người cho mình xin đoạn code để có thể xuất file này dưới dạng Value (giống như mình copy toàn bộ file, sang file mới và Paste as Value), file lưu ở ổ đĩa D, tên đặt theo định dạng thời gian của lúc xuất: TK-[năm]-[tháng]-[ngày]-[giờ]-[phút]-[giây].xlsx

Cám ơn mọi người đã đọc bài. Chúc mọi người một ngày tốt lành.

Làm chút cho bạn, tớ làm file trên Macos nên có lẽ bạn thử trên windows mà báo lỗi chi thì báo lại để sửa cho phù hạp..

 

[marcosheath479]

Mình cám ơn mọi người đã hỗ trợ. Chúc mọi người một ngày tốt lành