Code save as sheet hiện hành (1 người xem)

  • Thread starter Thread starter pro8x
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
P

pro8x

Thành viên hoạt động
Tham gia
3/11/11
Bài viết
142
Được thích
24
Các thầy cho e hỏi về đoanj code để saveas sheet hiện hành với ah. Cụ thể e có 1 file có khoảng 10 sheet, giờ e muốn tạo 1 code saveas để khi chạy code này thì sẽ saveas file dưới dạng .xls nhưng chỉ save sheet hiện hành thui.E có viết code nhưng nó save cả file tìm mãi ma không ra.mong các thầy giúp +-+-+-+ +-+-+-+
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
pro8x đã viết:
Các thầy cho e hỏi về đoanj code để saveas sheet hiện hành với ah. Cụ thể e có 1 file có khoảng 10 sheet, giờ e muốn tạo 1 code saveas để khi chạy code này thì sẽ saveas file dưới dạng .xls nhưng chỉ save sheet hiện hành thui.E có viết code nhưng nó save cả file tìm mãi ma không ra.mong các thầy giúp +-+-+-+ +-+-+-+
Nhấp chuột vào đây để mở rộng...

Hỏi lại bạn: Nếu làm bằng tay thì bạn làm thế nào?
Nếu như bằng tay bạn làm được thì cứ record macro những thao tác vừa làm ---> Tự nhiên có code, khỏi cần hỏi
 
Upvote 0
pro8x đã viết:
Các thầy cho e hỏi về đoanj code để saveas sheet hiện hành với ah. Cụ thể e có 1 file có khoảng 10 sheet, giờ e muốn tạo 1 code saveas để khi chạy code này thì sẽ saveas file dưới dạng .xls nhưng chỉ save sheet hiện hành thui.E có viết code nhưng nó save cả file tìm mãi ma không ra.mong các thầy giúp +-+-+-+ +-+-+-+
Nhấp chuột vào đây để mở rộng...

Không biết bạn đã tự làm được chưa? Code thế nào? Có thể post lên cho tôi tham khảo được không?
Tôi hỏi thế vì sau khi trả lời ở bài 2, tôi đã suy nghĩ đến việc sẽ viết 1 code ở MỨC TỔNG QUÁT NHẤT
Nếu bạn vẫn còn quan tâm vấn đề này, tôi sẽ nghiên cứu tiếp tục (để bạn hoặc ai đó xài thoải mái nhất)
Sao?
 
Upvote 0
ndu96081631 đã viết:
Không biết bạn đã tự làm được chưa? Code thế nào? Có thể post lên cho tôi tham khảo được không?
Tôi hỏi thế vì sau khi trả lời ở bài 2, tôi đã suy nghĩ đến việc sẽ viết 1 code ở MỨC TỔNG QUÁT NHẤT
Nếu bạn vẫn còn quan tâm vấn đề này, tôi sẽ nghiên cứu tiếp tục (để bạn hoặc ai đó xài thoải mái nhất)
Sao?
Nhấp chuột vào đây để mở rộng...
Em rất cảm ơn thầy.Hôm qua e đi làm lên chưa Replay lại được. Em có thử record bàng Macro nhưng làm thủ công khi savas thì vẫn không được đi.Hic. Mong thầy giup đỡ tiép
 
Upvote 0
pro8x đã viết:
Em rất cảm ơn thầy.Hôm qua e đi làm lên chưa Replay lại được. Em có thử record bàng Macro nhưng làm thủ công khi savas thì vẫn không được đi.Hic. Mong thầy giup đỡ tiép
Nhấp chuột vào đây để mở rộng...

OK! Nếu bạn có nhu cầu tôi sẽ nghiên cứu
(Tối nay hoặc ngày mai sẽ có kết quả)
 
Upvote 0
Code cho bạn đây:
Mã: 
Function SaveSheet(ByVal Sheets2Save As Object, ByVal FileName2Save As String, _
                   ByVal FileFormat As XlFileFormat, ByVal OverWrite As Boolean) As String
  Dim bChk As Boolean
  Dim Folder2Save As String, sComm As String, Ext As String, ErrMsg As String
  Dim fso As Object, oWsh As Object, wkb As Workbook
  On Error GoTo ExitFunc
  Set fso = CreateObject("Scripting.FileSystemObject")
  bChk = fso.FileExists(FileName2Save)
  If (bChk = False) Or OverWrite Then
    Folder2Save = Mid(FileName2Save, 1, InStrRev(FileName2Save, "\") - 1)
    If fso.FolderExists(Folder2Save) = False Then
      Set oWsh = CreateObject("Wscript.Shell")
      sComm = "MkDir " & """" & Folder2Save & """"
      oWsh.Run "cmd /u /c " & sComm, 0, True
    End If
    If fso.FolderExists(Folder2Save) Then
      Ext = fso.GetExtensionName(FileName2Save)
      If Len(Ext) Then FileName2Save = Left(FileName2Save, Len(FileName2Save) - Len(Ext) - 1)
      If (TypeName(Sheets2Save) = "Sheets") Or (TypeName(Sheets2Save) = "Worksheet") Then
        Application.DisplayAlerts = False
        Sheets2Save.Copy
        Set wkb = ActiveWorkbook
        With wkb
          .SaveAs FileName2Save, FileFormat
          SaveSheet = .FullName
          .Close (True)
        End With
        Application.DisplayAlerts = True
      End If
    End If
  End If
ExitFunc:
  ErrMsg = Err.Description
  If Err.Number = 1004 Then
    If Not wkb Is Nothing Then
      If UCase(wkb.Name) <> UCase(Sheets2Save.Parent.Name) Then wkb.Close (False)
    End If
    MsgBox ErrMsg
  End If
  Set fso = Nothing: Set oWsh = Nothing
End Function
Mã: 
Sub Main()
' XlFileFormat = xlExcel8                      <===> File Extension = "xls"
' XlFileFormat = xlOpenXMLWorkbook             <===> File Extension = "xlsx"
' XlFileFormat = xlExcel12                     <===> File Extension = "xlsb"
' XlFileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Extension = "xlsm"
  Dim wks As Object, FileFormat As XlFileFormat
  Dim FileName As String, szSaved As String
  Application.ScreenUpdating = False
  Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) '>> wks bao gom nhieu sheet
  'Set wks = ThisWorkbook.Worksheets("Sheet1")             '>> wks là 1 sheet duy nhat
  FileName = "D:\ABC\Test.xls"
  FileFormat = xlExcel8
  szSaved = SaveSheet(wks, FileName, FileFormat, True)
  If Len(szSaved) Then MsgBox "File """ & szSaved & """ have been successfully saved!"
  Application.ScreenUpdating = True
End Sub
Hàm SaveSheet bạn không cần quan tâm, chỉ cần biết áp dụng tại sheet Main
Cú pháp hàm:
SaveSheet(Sheet cần lưu, Đường dẫn file sẽ lưu, kiểu định dạng file, cho lưu đè hay không?)
Lưu ý:
- Sheet cần lưu (Sheets2Save) có thể là 1 hoặc nhiều sheet
Ví dụ:
Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) ---> Lưu 2 sheet thành file
Set wks = ThisWorkbook.Worksheets("Sheet1") ---> Lưu 1 sheet duy nhất
- Đường dẫn file sẽ lưu (FileName2Save): Thư mục chứa đường dẫn đến file có thể đã tồn tại hoặc chưa. Nếu thư mục lưu file chưa tồn tại thì code sẽ tự động tạo ra nó
- kiểu định dạng file (FileFormat):
FileFormat = xlExcel8 <===> Đuôi file = "xls"​
​
FileFormat = xlOpenXMLWorkbook <===> Đuôi file = "xlsx"​
​
FileFormat = xlExcel12 <===> Đuôi file = "xlsb"​
​
FileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Đuôi file = "xlsm"​
- Cho lưu đè (OverWrite): OverWrite = TRUE sẽ cho lưu đè và ngược lại
-------------------
Vậy bạn chỉ cần quan tâm 3 dòng code màu đỏ và khai báo cho đúng là đủ
 

File đính kèm

Upvote 0
ndu96081631 đã viết:
Code cho bạn đây:
Nhấp chuột vào đây để mở rộng...
Em xin cảm ơn thầy đã giúp. Còn 1 vấn đề em muốn hỏi mong thầy giúp
1. E muốn saveas sheet hiện hành thui. Nếu như code của thầy thì muốn save sheet nào lại phải sủa main_Sub. trong khi đó các sheet saveas mỗi ngày lại khác nhau. => Vấn đề này e đã sửa laaij code tạm thời OK
2. Sau khi saveas thì toàn bộ code của file bị mất. Cái này e chưa sửa được mong thầy chỉ thêm
Đây là code sau khi e sửa lại
Mã: 
Sub Main()' XlFileFormat = xlExcel8                      <===> File Extension = "xls"
' XlFileFormat = xlOpenXMLWorkbook             <===> File Extension = "xlsx"
' XlFileFormat = xlExcel12                     <===> File Extension = "xlsb"
' XlFileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Extension = "xlsm"
  Dim wks As Object, FileFormat As XlFileFormat
  Dim FileName As String, szSaved As String
  Application.ScreenUpdating = False
  'Set wks = ThisWorkbook.ActiveSheet(Range("e19").VALUE) '>> wks bao gom nhieu sheet
  Set wks = ThisWorkbook.Worksheets(Range("E19").Value)             '>> wks là 1 sheet duy nhat
 ' FileName = "D:\Test.xls"
  FileName = ActiveSheet.Range("A1").Value & "\" & ActiveSheet.Range("A2").Value
  FileFormat = xlExcel8
  szSaved = SaveSheet(wks, FileName, FileFormat, True)
 
  If Len(szSaved) Then MsgBox "File """ & szSaved & """ have been successfully saved!"
  Application.ScreenUpdating = True
End Sub
 
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote 0
pro8x đã viết:
Em xin cảm ơn thầy đã giúp. Còn 1 vấn đề em muốn hỏi mong thầy giúp
1. E muốn saveas sheet hiện hành thui. Nếu như code của thầy thì muốn save sheet nào lại phải sủa main_Sub. trong khi đó các sheet saveas mỗi ngày lại khác nhau. => Vấn đề này e đã sửa laaij code tạm thời OK
Nhấp chuột vào đây để mở rộng...
Bạn muốn save sheet hiện hành thì: Set wks = ActiveSheet thôi là được rồi chứ gì
pro8x đã viết:
2. Sau khi saveas thì toàn bộ code của file bị mất. Cái này e chưa sửa được mong thầy chỉ thêm
Nhấp chuột vào đây để mở rộng...

Chổ này tôi không hiểu! Mất là mất thế nào chứ?
 
Upvote 0
ndu96081631 đã viết:
Bạn muốn save sheet hiện hành thì: Set wks = ActiveSheet thôi là được rồi chứ gì


Chổ này tôi không hiểu! Mất là mất thế nào chứ?
Nhấp chuột vào đây để mở rộng...
Ah thầy ơi ý e là thế này.
Ví dụ file chính có các macro thì khi saveas file saveas vẫn phải có các macro đó. Không biết có được không ah mong thầy giúp
 
Upvote 0
pro8x đã viết:
Ah thầy ơi ý e là thế này.
Ví dụ file chính có các macro thì khi saveas file saveas vẫn phải có các macro đó. Không biết có được không ah mong thầy giúp
Nhấp chuột vào đây để mở rộng...

Nếu là macro trong sheet (chẳng hạn Private Sub Worksheet_Change) thì sau khi lưu, cái macro ấy cũng được mang theo
Nếu là macro trong Module thì... bạn nghĩ sao? Có cái gì chứng minh rằng Module A, B, C nào đó là đang thuộc về ActiveSheet
Logic vấn đề nó vậy thôi ---> Bạn tự suy luận đi
--------------------
Mà nghĩ cũng lạ: Thường người ta muốn Save As và xóa hết mọi code. Bạn lại muốn làm được ngược lại?
???
 
Upvote 0
ndu96081631 đã viết:
Nếu là macro trong sheet (chẳng hạn Private Sub Worksheet_Change) thì sau khi lưu, cái macro ấy cũng được mang theo
Nếu là macro trong Module thì... bạn nghĩ sao? Có cái gì chứng minh rằng Module A, B, C nào đó là đang thuộc về ActiveSheet
Logic vấn đề nó vậy thôi ---> Bạn tự suy luận đi
--------------------
Mà nghĩ cũng lạ: Thường người ta muốn Save As và xóa hết mọi code. Bạn lại muốn làm được ngược lại?
???
Nhấp chuột vào đây để mở rộng...
Vâng cảm ơn thầy, cái này e cũng biết nhưng muốn hỏi xem có cách nào giữ lại không thôi. E giữ lại macro ví file saveas này, sau đó sẽ được kiểm tra lại và chạy 1 thủ tục save PDF nữa ah
 
Upvote 0
pro8x đã viết:
Vâng cảm ơn thầy, cái này e cũng biết nhưng muốn hỏi xem có cách nào giữ lại không thôi. E giữ lại macro ví file saveas này, sau đó sẽ được kiểm tra lại và chạy 1 thủ tục save PDF nữa ah
Nhấp chuột vào đây để mở rộng...

Một code mà save ra tùm lum các file? Chắc là bạn muốn xài nhiều lần trên nhiều file? Vậy sao không Save code thành 1 AddIn luôn cho tiện
Nếu muốn, tôi có thể nghiên cứu thêm vấn đề này để bạn dùng thuận tiện hơn
 
Upvote 0
ndu96081631 đã viết:
Một code mà save ra tùm lum các file? Chắc là bạn muốn xài nhiều lần trên nhiều file? Vậy sao không Save code thành 1 AddIn luôn cho tiện
Nếu muốn, tôi có thể nghiên cứu thêm vấn đề này để bạn dùng thuận tiện hơn
Nhấp chuột vào đây để mở rộng...
Vâng mong thầy chỉ thêm về vấn đề này ah
 
Upvote 0
pro8x đã viết:
Vâng mong thầy chỉ thêm về vấn đề này ah
Nhấp chuột vào đây để mở rộng...

Phần code chính để chạy thật sự không có khó khăn gì, nhưng để Save thành 1 AddIn và mang tính tiện dụng cho bạn thì phần xây dựng giao diện quả thật khó khăn đối với tôi
Sau mấy ngày nghiên cứu, tôi tạm xây dụng giao diện thế này

Untitled_1.jpg








Lần đầu tiên sử dụng thì chắc chắn cửa sổ Help sẽ hiện ra. Đọc kỹ hướng dẫn trong đó là được rồi:

Untitled_2.jpg




































Cảm ơn sự tư vấn của các bạn tại topic này: Nhờ tư vấn thiết kế CỬA SỔ HELP


----------------
Code chính: vẫn là code lần trước
Code tạo menu:
Mã: 
Private Sub Auto_Open()
  Dim lCount As Long
  BuildBar
  lCount = GetSetting("Sheets2Files", "Settings", "lCount", 0)
  If lCount = 0 Then
    lCount = lCount + 1
    SaveSetting "Sheets2Files", "Settings", "lCount", lCount
    ShowHelp
  End If
End Sub
Mã: 
Private Sub Auto_Close()
  DelBar
End Sub
Mã: 
Private Sub ShowHelp()
  Dim dlg As DialogSheet
  Set dlg = ThisWorkbook.DialogSheets("Help")
  dlg.Show
End Sub
Mã: 
Private Sub BuildBar()
  DelBar
  With Application.CommandBars.Add("Save Sheets")
   .Visible = True
    With .Controls.Add(msoControlEdit)
      .Caption = "Save to"
      .TooltipText = "Enter the path to save files..."
      .Style = msoComboLabel
      .OnAction = "SavePath_Setting"
      .Text = GetSetting("Sheets2Files", "Settings", "Path", "")
    End With
    With .Controls.Add(msoControlButton)
      .Caption = "Browse"
      .Style = msoButtonCaption
      .OnAction = "BrowseForFolder"
    End With
    .Controls.Add (msoControlButton)
    With .Controls.Add(msoControlEdit)
      .Caption = "File Name"
      .TooltipText = "Enter the File Name to save"
      .Style = msoComboLabel
      .OnAction = "FileName_Setting"
      .Text = GetSetting("Sheets2Files", "Settings", "FileName", "")
    End With
    .Controls.Add (msoControlButton)
    With .Controls.Add(msoControlDropdown)
      .Caption = "File Type"
      .TooltipText = "Select a file type"
      .Style = msoComboLabel
      .AddItem "Excel Workbook (*.xlsx)"
      .AddItem "Excel Macro-Enabled Workbook (*.xlsm)"
      .AddItem "Excel Binary Workbook (*.xlsb)"
      .AddItem "Excel 97-2003 Workbook (*.xls)"
      .OnAction = "FileType_Setting"
      Dim index As Long
      index = GetSetting("Sheets2Files", "Settings", "FileType", 0)
      If index > 0 Then .ListIndex = index
    End With
    .Controls.Add (msoControlButton)
    With .Controls.Add(msoControlButton)
      .Caption = "Save Selected Sheets"
      .Style = msoButtonIconAndCaption
      .FaceId = 3
      .OnAction = "SaveSheet2File"
    End With
    .Controls.Add (msoControlButton)
    With .Controls.Add(msoControlButton)
      .Caption = "Help"
      .Style = msoButtonIconAndCaption
      .OnAction = "ShowHelp"
      .FaceId = 984
    End With
  End With
End Sub
Mã: 
Private Sub DelBar()
  On Error Resume Next
  Application.CommandBars("Save Sheets").Delete
End Sub
Mã: 
Private Sub SavePath_Setting()
  Dim strPath As String
  On Error Resume Next
  strPath = Application.CommandBars("Save Sheets").Controls("Save to").Text
  SaveSetting "Sheets2Files", "Settings", "Path", strPath
End Sub
Mã: 
Private Sub BrowseForFolder()
  Dim sPath As String
  On Error Resume Next
  With CreateObject("Shell.Application")
    sPath = .BrowseForFolder(0, "", 1).Self.Path
  End With
  Application.CommandBars("Save Sheets").Controls("Save to").Text = sPath
  SavePath_Setting
End Sub
Mã: 
Private Sub FileName_Setting()
  Dim strName As String
  On Error Resume Next
  strName = Application.CommandBars("Save Sheets").Controls("File Name").Text
  SaveSetting "Sheets2Files", "Settings", "FileName", strName
End Sub
Mã: 
Private Sub FileType_Setting()
  Dim index As Long
  On Error Resume Next
  index = Application.CommandBars("Save Sheets").Controls("File Type").ListIndex
  SaveSetting "Sheets2Files", "Settings", "FileType", index
End Sub
Mã: 
Private Sub SaveSheet2File()
' XlFileFormat = xlExcel8                      <===> File Extension = "xls"  : Value = 56
' XlFileFormat = xlOpenXMLWorkbook             <===> File Extension = "xlsx" : Value = 51
' XlFileFormat = xlExcel12                     <===> File Extension = "xlsb" : Value = 50
' XlFileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Extension = "xlsm" : Value = 52
  Dim wks As Object, FileFormat As Long, index As Long
  Dim FileName As String, szSaved As String, strPath As String, strName As String
  On Error Resume Next
  Application.ScreenUpdating = False
  Set wks = ActiveWindow.SelectedSheets
  index = GetSetting("Sheets2Files", "Settings", "FileType", 0)
  strPath = GetSetting("Sheets2Files", "Settings", "Path", "")
  strName = GetSetting("Sheets2Files", "Settings", "FileName", "")
  Select Case index
    Case Is = 1: FileFormat = 51
    Case Is = 2: FileFormat = 52
    Case Is = 3: FileFormat = 50
    Case Is = 4: FileFormat = 56
  End Select
  If Len(strPath) * Len(strName) Then
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    If FileFormat > 0 Then
      FileName = strPath & strName
      szSaved = modSaveSheets.SaveSheets(wks, FileName, FileFormat, True)
      If Len(szSaved) Then MsgBox "File """ & szSaved & """ have been successfully saved!"
    Else
      MsgBox "Please select a file type", , "WARNING!"
    End If
  Else
    MsgBox "Please setup the path and file name:" & vbLf & _
           "- Press 'Browse' button or type the path in 'Save to' Edit Box" & vbLf & _
           "- Type the file name in 'File Name' Edit Box", , "WARNING!"
  End If
  Application.ScreenUpdating = True
End Sub
-----------------
Vui lòng download file đính kèm và test giúp tôi xem còn chổ nào phải cải tiến thêm nữa không?
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Xin cảm ơn thầy đã giúp, E muốn hỏi là phần File Name có thể viêt code để nó lấy tên theo tên có sẵn trong cell của sheet hiện hành không ah. ( ở đây là cell AF6),và phần File type có thể thêm lưu PDF vào không
 
Upvote 0
pro8x đã viết:
Xin cảm ơn thầy đã giúp, E muốn hỏi là phần File Name có thể viêt code để nó lấy tên theo tên có sẵn trong cell của sheet hiện hành không ah. ( ở đây là cell AF6),và phần File type có thể thêm lưu PDF vào không
Nhấp chuột vào đây để mở rộng...

Phần File Type hoàn toàn không có vấn đề
Riêng phần file name thì tôi đang suy nghĩ xem thiết kế thế nào cho tổng quát nhất... Đáp ứng yêu cầu của bạn chẳng khó khăn gì, nhưng tôi lại không thích viết 1 ứng dụng chỉ 1 người xài. Ý tôi là nó phải ở mức tổng quát để ai xài cũng được
Để tính lại xem
 
Upvote 0
pro8x đã viết:
Xin cảm ơn thầy đã giúp, E muốn hỏi là phần File Name có thể viêt code để nó lấy tên theo tên có sẵn trong cell của sheet hiện hành không ah. ( ở đây là cell AF6),và phần File type có thể thêm lưu PDF vào không
Nhấp chuột vào đây để mở rộng...

Chúng ta thống nhất quy định này nhé:
- Nếu bạn gõ vào hộp File Name 1 tên nào đó (abc.xls chẳng hạn) thì đương nhiên đó sẽ tên của file lưu
- Nếu bạn muốn lấy giá trị của 1 cell nào đó làm tên file (là cell A6 chẳng hạn) thì bạn sẽ ghi vào hộp File Name thế này: |A6| ---> Có 2 dấu | ở đầu và cuối để code phân biệt
- Trường hợp cell mà bạn muốn đặt làm tên file nằm ở 1 sheet khác (là cell A6 ở Sheet3 chẳng hạn), bạn sẽ ghi vào hộp File Name thế này: |Sheet3!A6|
Đồng ý chứ?
Tôi sẽ chỉnh lại code theo hướng trên, đồng thời cho thêm kiểu file PDF vào hộp File Type như ý của bạn. Cách dùng vẫn như trước
 

File đính kèm

Upvote 0
Xin cảm ơn thầy.Dung với ý e rồi đấy ah.hi
 
Upvote 0
Mình cũng hay lưu sheet hiện hành để gửi báo cáo riêng 1 sheet. Code mình viết bằng Record rồi thực hiện thôi (tạo một workbook mới > move copy sheet hiện hành qua workbook mới > lưu file .xls > close workbook.
PHP: 
Sub ChonNoiLuuBaoCao()
Dim MyFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            MyFolder = .SelectedItems(1)
            Call LuuBaoCao
        Else
            Exit Sub
        End If
    End With
End Sub
  
Sub LuuBaoCao()
On Error Resume Next
Application.ScreenUpdating = False
Dim x As String, a As String, b As String
    x = ThisWorkbook.Name
    b = ActiveSheet.Name 'Ten sheet hien hanh
    Workbooks.Add 'Tao moi 01 workbook
    a = b & " " & Day(Now()) & "-" & Month(Now()) & "-" & Right(Year(Now()), 2) 'Ten sheet + ngay thang nam
    y = a & ".xls" 'Ten file khi save as type *xls
    
    ActiveWorkbook.SaveAs Filename:=y, FileFormat:= _
    xlExcel8, CreateBackup:=False 'save as type *xls
    Windows(x).Activate
    With ActiveSheet
        .Select
        .Copy Before:=Workbooks(y).Sheets(1)
    End With
    With Workbooks(y)
        .Activate
        .Save
        .Close
    End With
    MsgBox "SaveAs file thanh cong", vbInformation, "Thong Bao"
Application.ScreenUpdating = True
End Sub

anh NDU ơi góp ý giúp em nếu bỏ qua thông báo replace file khi trùng tên cũ thì em nên viết vào code này thêm dòng lệnh nào nữa vậy anh.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
qtm1987 đã viết:
Mình cũng hay lưu sheet hiện hành để gửi báo cáo riêng 1 sheet. Code mình viết bằng Record rồi thực hiện thôi (tạo một workbook mới > move copy sheet hiện hành qua workbook mới > lưu file .xls > close workbook.
Mã: 
Sub ChonNoiLuuBaoCao()
Dim MyFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            MyFolder = .SelectedItems(1)
            Call LuuBaoCao
        Else
            Exit Sub
        End If
    End With
End Sub
  
Sub LuuBaoCao()
On Error Resume Next
Application.ScreenUpdating = False
Dim x As String, a As String, b As String
    x = ThisWorkbook.Name
    b = ActiveSheet.Name 'Ten sheet hien hanh
    Workbooks.Add 'Tao moi 01 workbook
    a = b & " " & Day(Now()) & "-" & Month(Now()) & "-" & Right(Year(Now()), 2) 'Ten sheet + ngay thang nam
    y = a & ".xls" 'Ten file khi save as type *xls
    
    [B][COLOR=#ff0000]ActiveWorkbook.SaveAs Filename:=y, FileFormat:= _
    xlExcel8, CreateBackup:=False 'save as type *xls[/COLOR][/B]
    Windows(x).Activate
    With ActiveSheet
        .Select
        .Copy Before:=Workbooks(y).Sheets(1)
    End With
    With Workbooks(y)
        .Activate
        .Save
        .Close
    End With
    MsgBox "SaveAs file thanh cong", vbInformation, "Thong Bao"
Application.ScreenUpdating = True
End Sub

anh NDU ơi góp ý giúp em nếu bỏ qua thông báo replace file khi trùng tên cũ thì em nên viết vào code này thêm dòng lệnh nào nữa vậy anh.
Nhấp chuột vào đây để mở rộng...
Đê ý dòng code màu đỏ nha
Thêm vào dòng lệnh Application.DisplayAlerts = False trước dòng màu đò và Application.DisplayAlerts = True sau dòng màu đỏ. Tức
Mã: 
Application.DisplayAlerts = False 
[COLOR=#ff0000][B]ActiveWorkbook.SaveAs Filename:=y, FileFormat:= _
    xlExcel8, CreateBackup:=False 'save as type *xls[/B][/COLOR]
Application.DisplayAlerts = True
 
Upvote 0
pro8x đã viết:
Ah thầy ơi ý e là thế này.
Ví dụ file chính có các macro thì khi saveas file saveas vẫn phải có các macro đó. Không biết có được không ah mong thầy giúp
Nhấp chuột vào đây để mở rộng...
Tưởng chỉ lưu sheet đó ra như dạng backup data thôi chứ, lưu macro theo chi cho nặng file.
 
Upvote 0
Code xuất sheet hiện hành thành File riêng trong cùng thư mục

Anh NDU ơi! mình gửi File mẫu rồi nè anh xem dùm nha. Thân ái chào anh.
File mẫu View attachment file mau 1.rar
 
Upvote 0
Upvote 0
van80 đã viết:
Mình đang dùng excel 2003 anh chỉ rõ một tí nha qua video trên mình không hiểu. Cám ơn anh nhiều.
Nhấp chuột vào đây để mở rộng...

Tôi không dùng Excel 2003 nên không biết đâu
Vậy có vấn đề gì, bạn cứ quay phim quá trình bạn thao tác rồi đưa lên đây nhé
Ngoài ra, nếu nghi ngờ file này bị lỗi, bạn có thể thí nghiệm bằng 1 file mới khác xem quá trình SaveSheet có trục trặc gì không?
 
Upvote 0
ndu96081631 đã viết:
Tôi không dùng Excel 2003 nên không biết đâu
Vậy có vấn đề gì, bạn cứ quay phim quá trình bạn thao tác rồi đưa lên đây nhé
Ngoài ra, nếu nghi ngờ file này bị lỗi, bạn có thể thí nghiệm bằng 1 file mới khác xem quá trình SaveSheet có trục trặc gì không?
Nhấp chuột vào đây để mở rộng...
Cám ơn anh nhiều , mình có làm rồi nhưng xuất ra là thư mục rỗng, mình cũng biết tại sao nữa. Anh xem code này nhé

Sub SaveFile()


Dim Ans As Integer
Dim Filt As String

Ans = MsgBox("Confirm you want to save this File." _
& (Chr(13) & Chr(10)) & (Chr(13) & Chr(10)) & _
"File will save as: Backup - (SheetNumber).xls in current directory", vbYesNo)


If Ans = vbNo Then Exit Sub
Application.DisplayAlerts = False
ThisWorkbook.SaveCopyAs Filename:=ActiveWorkbook.Path & "\Backup - " & ThisWorkbook.Name
Application.DisplayAlerts = True
ThisWorkbook.Close
End Sub


code này lưu (backup) nguyên cả 1 file trong cùng 1 thư mục.
Nhưng mình chỉ cần save sheet hiện hành thành 1 file riêng.
file đính kèm View attachment backup.xls
 
Upvote 0
ndu96081631 đã viết:
Code cho bạn đây:
Nhấp chuột vào đây để mở rộng...

Xin lỗi phải lôi ra việc cũ. Nhưng thấy rất hay. Em có tạo toppic tương tự vấn đề này
nóng lòng chưa có câu trả lời. Lục những toppic có liên quan.

Sẵn đây rất mong anh NDU giúp thêm cách coppy tương tự nhưng chỉ coppy 1 vùng chỉ định trước ở sheet nguồn.
Em cám ơn nhiều!
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Xin lỗi thầy ndu vì e hỏi lại chủ đề này.
E hiện tại đang dùng 2 addin liên quan đến sheet.
1 cái là có phím tắt ctrl shift c để mở sheet hiện hành ra 1 file mới.
Còn 1 cái của thầy là lưu luôn ra 1 file riêng mà ko mở file đấy.
Có cách nào để chỉ dùng 1 addin của thầy mà có lựa chọn là lưu file hoặc lưu và mở file ko ạ?
 
Upvote 0
ndu96081631 đã viết:
Code cho bạn đây:
Mã: 
Function SaveSheet(ByVal Sheets2Save As Object, ByVal FileName2Save As String, _
                   ByVal FileFormat As XlFileFormat, ByVal OverWrite As Boolean) As String
  Dim bChk As Boolean
  Dim Folder2Save As String, sComm As String, Ext As String, ErrMsg As String
  Dim fso As Object, oWsh As Object, wkb As Workbook
  On Error GoTo ExitFunc
  Set fso = CreateObject("Scripting.FileSystemObject")
  bChk = fso.FileExists(FileName2Save)
  If (bChk = False) Or OverWrite Then
    Folder2Save = Mid(FileName2Save, 1, InStrRev(FileName2Save, "\") - 1)
    If fso.FolderExists(Folder2Save) = False Then
      Set oWsh = CreateObject("Wscript.Shell")
      sComm = "MkDir " & """" & Folder2Save & """"
      oWsh.Run "cmd /u /c " & sComm, 0, True
    End If
    If fso.FolderExists(Folder2Save) Then
      Ext = fso.GetExtensionName(FileName2Save)
      If Len(Ext) Then FileName2Save = Left(FileName2Save, Len(FileName2Save) - Len(Ext) - 1)
      If (TypeName(Sheets2Save) = "Sheets") Or (TypeName(Sheets2Save) = "Worksheet") Then
        Application.DisplayAlerts = False
        Sheets2Save.Copy
        Set wkb = ActiveWorkbook
        With wkb
          .SaveAs FileName2Save, FileFormat
          SaveSheet = .FullName
          .Close (True)
        End With
        Application.DisplayAlerts = True
      End If
    End If
  End If
ExitFunc:
  ErrMsg = Err.Description
  If Err.Number = 1004 Then
    If Not wkb Is Nothing Then
      If UCase(wkb.Name) <> UCase(Sheets2Save.Parent.Name) Then wkb.Close (False)
    End If
    MsgBox ErrMsg
  End If
  Set fso = Nothing: Set oWsh = Nothing
End Function
Mã: 
Sub Main()
' XlFileFormat = xlExcel8                      <===> File Extension = "xls"
' XlFileFormat = xlOpenXMLWorkbook             <===> File Extension = "xlsx"
' XlFileFormat = xlExcel12                     <===> File Extension = "xlsb"
' XlFileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Extension = "xlsm"
  Dim wks As Object, FileFormat As XlFileFormat
  Dim FileName As String, szSaved As String
  Application.ScreenUpdating = False
  [COLOR=#ff0000]Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2"))[/COLOR] '>> wks bao gom nhieu sheet
  'Set wks = ThisWorkbook.Worksheets("Sheet1")             '>> wks là 1 sheet duy nhat
[COLOR=#ff0000] FileName = "D:\ABC\Test.xls"
  FileFormat = xlExcel8[/COLOR]
  szSaved = SaveSheet(wks, FileName, FileFormat, True)
  If Len(szSaved) Then MsgBox "File """ & szSaved & """ have been successfully saved!"
  Application.ScreenUpdating = True
End Sub
Hàm SaveSheet bạn không cần quan tâm, chỉ cần biết áp dụng tại sheet Main
Cú pháp hàm:
SaveSheet(Sheet cần lưu, Đường dẫn file sẽ lưu, kiểu định dạng file, cho lưu đè hay không?)
Lưu ý:
- Sheet cần lưu (Sheets2Save) có thể là 1 hoặc nhiều sheet
Ví dụ:
Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) ---> Lưu 2 sheet thành file
Set wks = ThisWorkbook.Worksheets("Sheet1") ---> Lưu 1 sheet duy nhất
- Đường dẫn file sẽ lưu (FileName2Save): Thư mục chứa đường dẫn đến file có thể đã tồn tại hoặc chưa. Nếu thư mục lưu file chưa tồn tại thì code sẽ tự động tạo ra nó
- kiểu định dạng file (FileFormat):
FileFormat = xlExcel8 <===> Đuôi file = "xls"​
​
FileFormat = xlOpenXMLWorkbook <===> Đuôi file = "xlsx"​
​
FileFormat = xlExcel12 <===> Đuôi file = "xlsb"​
​
FileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Đuôi file = "xlsm"​
- Cho lưu đè (OverWrite): OverWrite = TRUE sẽ cho lưu đè và ngược lại
-------------------
Vậy bạn chỉ cần quan tâm 3 dòng code màu đỏ và khai báo cho đúng là đủ
Nhấp chuột vào đây để mở rộng...
Anh Tuấn ơi! em cũng đang sử dụng code này của anh. Nếu mà muốn bỏ các công thức (chỉ lây giá trị) trong sheet khi lưu thành file mới thì sửa code thế nào vậy anh.
 
Upvote 0
chiendich đã viết:
Anh Tuấn ơi! em cũng đang sử dụng code này của anh. Nếu mà muốn bỏ các công thức (chỉ lây giá trị) trong sheet khi lưu thành file mới thì sửa code thế nào vậy anh.
Nhấp chuột vào đây để mở rộng...

Ôi topic quá hay và tuyệt vời. Tks Thầy Tuấn và các anh chị trong topic này đã chia sẻ kiến thức quý báu này.

Em đúng cũng là đang cần thầy Tuấn đưa ra giải pháp bổ sung cho vấn đề của bạn chiến dịch đã nêu. Rất mong thầy hướng dẫn ạ.

Tks all.
 
Upvote 0
ndu96081631 đã viết:
Code cho bạn đây:
Mã: 
Function SaveSheet(ByVal Sheets2Save As Object, ByVal FileName2Save As String, _
                   ByVal FileFormat As XlFileFormat, ByVal OverWrite As Boolean) As String
  Dim bChk As Boolean
  Dim Folder2Save As String, sComm As String, Ext As String, ErrMsg As String
  Dim fso As Object, oWsh As Object, wkb As Workbook
  On Error GoTo ExitFunc
  Set fso = CreateObject("Scripting.FileSystemObject")
  bChk = fso.FileExists(FileName2Save)
  If (bChk = False) Or OverWrite Then
    Folder2Save = Mid(FileName2Save, 1, InStrRev(FileName2Save, "\") - 1)
    If fso.FolderExists(Folder2Save) = False Then
      Set oWsh = CreateObject("Wscript.Shell")
      sComm = "MkDir " & """" & Folder2Save & """"
      oWsh.Run "cmd /u /c " & sComm, 0, True
    End If
    If fso.FolderExists(Folder2Save) Then
      Ext = fso.GetExtensionName(FileName2Save)
      If Len(Ext) Then FileName2Save = Left(FileName2Save, Len(FileName2Save) - Len(Ext) - 1)
      If (TypeName(Sheets2Save) = "Sheets") Or (TypeName(Sheets2Save) = "Worksheet") Then
        Application.DisplayAlerts = False
        Sheets2Save.Copy
        Set wkb = ActiveWorkbook
        With wkb
          .SaveAs FileName2Save, FileFormat
          SaveSheet = .FullName
          .Close (True)
        End With
        Application.DisplayAlerts = True
      End If
    End If
  End If
ExitFunc:
  ErrMsg = Err.Description
  If Err.Number = 1004 Then
    If Not wkb Is Nothing Then
      If UCase(wkb.Name) <> UCase(Sheets2Save.Parent.Name) Then wkb.Close (False)
    End If
    MsgBox ErrMsg
  End If
  Set fso = Nothing: Set oWsh = Nothing
End Function
Mã: 
Sub Main()
' XlFileFormat = xlExcel8                      <===> File Extension = "xls"
' XlFileFormat = xlOpenXMLWorkbook             <===> File Extension = "xlsx"
' XlFileFormat = xlExcel12                     <===> File Extension = "xlsb"
' XlFileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Extension = "xlsm"
  Dim wks As Object, FileFormat As XlFileFormat
  Dim FileName As String, szSaved As String
  Application.ScreenUpdating = False
  [COLOR=#ff0000]Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2"))[/COLOR] '>> wks bao gom nhieu sheet
  'Set wks = ThisWorkbook.Worksheets("Sheet1")             '>> wks là 1 sheet duy nhat
[COLOR=#ff0000] FileName = "D:\ABC\Test.xls"
  FileFormat = xlExcel8[/COLOR]
  szSaved = SaveSheet(wks, FileName, FileFormat, True)
  If Len(szSaved) Then MsgBox "File """ & szSaved & """ have been successfully saved!"
  Application.ScreenUpdating = True
End Sub
Hàm SaveSheet bạn không cần quan tâm, chỉ cần biết áp dụng tại sheet Main
Cú pháp hàm:
SaveSheet(Sheet cần lưu, Đường dẫn file sẽ lưu, kiểu định dạng file, cho lưu đè hay không?)
Lưu ý:
- Sheet cần lưu (Sheets2Save) có thể là 1 hoặc nhiều sheet
Ví dụ:
Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) ---> Lưu 2 sheet thành file
Set wks = ThisWorkbook.Worksheets("Sheet1") ---> Lưu 1 sheet duy nhất
- Đường dẫn file sẽ lưu (FileName2Save): Thư mục chứa đường dẫn đến file có thể đã tồn tại hoặc chưa. Nếu thư mục lưu file chưa tồn tại thì code sẽ tự động tạo ra nó
- kiểu định dạng file (FileFormat):
FileFormat = xlExcel8 <===> Đuôi file = "xls"​
​
FileFormat = xlOpenXMLWorkbook <===> Đuôi file = "xlsx"​
​
FileFormat = xlExcel12 <===> Đuôi file = "xlsb"​
​
FileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Đuôi file = "xlsm"​
- Cho lưu đè (OverWrite): OverWrite = TRUE sẽ cho lưu đè và ngược lại
-------------------
Vậy bạn chỉ cần quan tâm 3 dòng code màu đỏ và khai báo cho đúng là đủ
Nhấp chuột vào đây để mở rộng...
bác NuNu ơi cho em hỏi thêm một chút nếu chỉ muốn copy giá trị có được không bác. Ý em là khi save ra file mới vẫn còn công thức bác ạ. Em cảm ơn bác nhiều nhiều....
 
Upvote 0
ndu96081631 đã viết:
Code cho bạn đây:
Mã: 
Function SaveSheet(ByVal Sheets2Save As Object, ByVal FileName2Save As String, _
                   ByVal FileFormat As XlFileFormat, ByVal OverWrite As Boolean) As String
  Dim bChk As Boolean
  Dim Folder2Save As String, sComm As String, Ext As String, ErrMsg As String
  Dim fso As Object, oWsh As Object, wkb As Workbook
  On Error GoTo ExitFunc
  Set fso = CreateObject("Scripting.FileSystemObject")
  bChk = fso.FileExists(FileName2Save)
  If (bChk = False) Or OverWrite Then
    Folder2Save = Mid(FileName2Save, 1, InStrRev(FileName2Save, "\") - 1)
    If fso.FolderExists(Folder2Save) = False Then
      Set oWsh = CreateObject("Wscript.Shell")
      sComm = "MkDir " & """" & Folder2Save & """"
      oWsh.Run "cmd /u /c " & sComm, 0, True
    End If
    If fso.FolderExists(Folder2Save) Then
      Ext = fso.GetExtensionName(FileName2Save)
      If Len(Ext) Then FileName2Save = Left(FileName2Save, Len(FileName2Save) - Len(Ext) - 1)
      If (TypeName(Sheets2Save) = "Sheets") Or (TypeName(Sheets2Save) = "Worksheet") Then
        Application.DisplayAlerts = False
        Sheets2Save.Copy
        Set wkb = ActiveWorkbook
        With wkb
          .SaveAs FileName2Save, FileFormat
          SaveSheet = .FullName
          .Close (True)
        End With
        Application.DisplayAlerts = True
      End If
    End If
  End If
ExitFunc:
  ErrMsg = Err.Description
  If Err.Number = 1004 Then
    If Not wkb Is Nothing Then
      If UCase(wkb.Name) <> UCase(Sheets2Save.Parent.Name) Then wkb.Close (False)
    End If
    MsgBox ErrMsg
  End If
  Set fso = Nothing: Set oWsh = Nothing
End Function
Mã: 
Sub Main()
' XlFileFormat = xlExcel8                      <===> File Extension = "xls"
' XlFileFormat = xlOpenXMLWorkbook             <===> File Extension = "xlsx"
' XlFileFormat = xlExcel12                     <===> File Extension = "xlsb"
' XlFileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Extension = "xlsm"
  Dim wks As Object, FileFormat As XlFileFormat
  Dim FileName As String, szSaved As String
  Application.ScreenUpdating = False
  [COLOR=#ff0000]Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2"))[/COLOR] '>> wks bao gom nhieu sheet
  'Set wks = ThisWorkbook.Worksheets("Sheet1")             '>> wks là 1 sheet duy nhat
[COLOR=#ff0000] FileName = "D:\ABC\Test.xls"
  FileFormat = xlExcel8[/COLOR]
  szSaved = SaveSheet(wks, FileName, FileFormat, True)
  If Len(szSaved) Then MsgBox "File """ & szSaved & """ have been successfully saved!"
  Application.ScreenUpdating = True
End Sub
Hàm SaveSheet bạn không cần quan tâm, chỉ cần biết áp dụng tại sheet Main
Cú pháp hàm:
SaveSheet(Sheet cần lưu, Đường dẫn file sẽ lưu, kiểu định dạng file, cho lưu đè hay không?)
Lưu ý:
- Sheet cần lưu (Sheets2Save) có thể là 1 hoặc nhiều sheet
Ví dụ:
Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) ---> Lưu 2 sheet thành file
Set wks = ThisWorkbook.Worksheets("Sheet1") ---> Lưu 1 sheet duy nhất
- Đường dẫn file sẽ lưu (FileName2Save): Thư mục chứa đường dẫn đến file có thể đã tồn tại hoặc chưa. Nếu thư mục lưu file chưa tồn tại thì code sẽ tự động tạo ra nó
- kiểu định dạng file (FileFormat):
FileFormat = xlExcel8 <===> Đuôi file = "xls"​
​
FileFormat = xlOpenXMLWorkbook <===> Đuôi file = "xlsx"​
​
FileFormat = xlExcel12 <===> Đuôi file = "xlsb"​
​
FileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Đuôi file = "xlsm"​
- Cho lưu đè (OverWrite): OverWrite = TRUE sẽ cho lưu đè và ngược lại
-------------------
Vậy bạn chỉ cần quan tâm 3 dòng code màu đỏ và khai báo cho đúng là đủ
Nhấp chuột vào đây để mở rộng...
Thầy ơi cho em hỏi tý ạ
Hiện tại đường dẫn lưu file đang cố định (vd: D:\ABC\Test.xls)
Thay vì vậy thì chọn bảng hiện đường dẫn lưu file thì mình chỉnh thế nào vậy ạ
em cảm ơn thầy
 
Upvote 0
ppc0312 đã viết:
Dùng Getopenfilename, theo link
Nhấp chuột vào đây để mở rộng...
Tình huống Save sheet hiện hành thành một file thì tên file là chưa tồn tại, vậy liệu có dùng GetOpenFileName được không bạn? Tôi không nghĩ là được
Bài đã được tự động gộp:

authority đã viết:
Thầy ơi cho em hỏi tý ạ
Hiện tại đường dẫn lưu file đang cố định (vd: D:\ABC\Test.xls)
Thay vì vậy thì chọn bảng hiện đường dẫn lưu file thì mình chỉnh thế nào vậy ạ
em cảm ơn thầy
Nhấp chuột vào đây để mở rộng...
Bài số 18 là đầy đủ theo ý bạn rồi đó
 
Upvote 0
ndu96081631 đã viết:
Tình huống Save sheet hiện hành thành một file thì tên file là chưa tồn tại, vậy liệu có dùng GetOpenFileName được không bạn? Tôi không nghĩ là được
Bài đã được tự động gộp:


Bài số 18 là đầy đủ theo ý bạn rồi đó
Nhấp chuột vào đây để mở rộng...
dạ thầy cho em hỏi sau khi xuất bị lỗi sai định dạng file thì sao khắc phục ạ
em cảm ơn thầy
 

File đính kèm

  • 233.PNG
    233.PNG
    8.5 KB · Đọc: 13
Upvote 0
à nếu file bảo vệ bằng lockxls khi save as sheet hiện hành thì bị lỗi định dạng thầy ạ
còn nếu để file ko bảo vệ thì không bị lỗi này
@ndu96081631 :Nhưng nếu dùng lockxls mà bảo vệ thì làm sao khắc phục thầy nhỉ
em cảm ơn thầy
 
Upvote 0
authority đã viết:
à nếu file bảo vệ bằng lockxls khi save as sheet hiện hành thì bị lỗi định dạng thầy ạ
còn nếu để file ko bảo vệ thì không bị lỗi này
@ndu96081631 :Nhưng nếu dùng lockxls mà bảo vệ thì làm sao khắc phục thầy nhỉ
em cảm ơn thầy
Nhấp chuột vào đây để mở rộng...
Bảo vệ bằng lockxls rồi save as chi nữa bạn
 
Upvote 0
YêuCN đã viết:
Bảo vệ bằng lockxls rồi save as chi nữa bạn
Nhấp chuột vào đây để mở rộng...
dạ bảng tính nhiều sheet thì nặng. mà gửi cho người khác thì cũng chỉ cần bảng kết quả
nên em chỉ muốn save as bảng kết quả anh à
nhưng vẫn chưa tìm ra cách để bảo vệ xls mà vẫn đúng định dạng file ạ
 
Upvote 0
ndu96081631 đã viết:
Code cho bạn đây:
Mã: 
Function SaveSheet(ByVal Sheets2Save As Object, ByVal FileName2Save As String, _
                   ByVal FileFormat As XlFileFormat, ByVal OverWrite As Boolean) As String
  Dim bChk As Boolean
  Dim Folder2Save As String, sComm As String, Ext As String, ErrMsg As String
  Dim fso As Object, oWsh As Object, wkb As Workbook
  On Error GoTo ExitFunc
  Set fso = CreateObject("Scripting.FileSystemObject")
  bChk = fso.FileExists(FileName2Save)
  If (bChk = False) Or OverWrite Then
    Folder2Save = Mid(FileName2Save, 1, InStrRev(FileName2Save, "\") - 1)
    If fso.FolderExists(Folder2Save) = False Then
      Set oWsh = CreateObject("Wscript.Shell")
      sComm = "MkDir " & """" & Folder2Save & """"
      oWsh.Run "cmd /u /c " & sComm, 0, True
    End If
    If fso.FolderExists(Folder2Save) Then
      Ext = fso.GetExtensionName(FileName2Save)
      If Len(Ext) Then FileName2Save = Left(FileName2Save, Len(FileName2Save) - Len(Ext) - 1)
      If (TypeName(Sheets2Save) = "Sheets") Or (TypeName(Sheets2Save) = "Worksheet") Then
        Application.DisplayAlerts = False
        Sheets2Save.Copy
        Set wkb = ActiveWorkbook
        With wkb
          .SaveAs FileName2Save, FileFormat
          SaveSheet = .FullName
          .Close (True)
        End With
        Application.DisplayAlerts = True
      End If
    End If
  End If
ExitFunc:
  ErrMsg = Err.Description
  If Err.Number = 1004 Then
    If Not wkb Is Nothing Then
      If UCase(wkb.Name) <> UCase(Sheets2Save.Parent.Name) Then wkb.Close (False)
    End If
    MsgBox ErrMsg
  End If
  Set fso = Nothing: Set oWsh = Nothing
End Function
Mã: 
Sub Main()
' XlFileFormat = xlExcel8                      <===> File Extension = "xls"
' XlFileFormat = xlOpenXMLWorkbook             <===> File Extension = "xlsx"
' XlFileFormat = xlExcel12                     <===> File Extension = "xlsb"
' XlFileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Extension = "xlsm"
  Dim wks As Object, FileFormat As XlFileFormat
  Dim FileName As String, szSaved As String
  Application.ScreenUpdating = False
  Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) '>> wks bao gom nhieu sheet
  'Set wks = ThisWorkbook.Worksheets("Sheet1")             '>> wks là 1 sheet duy nhat
  FileName = "D:\ABC\Test.xls"
  FileFormat = xlExcel8
  szSaved = SaveSheet(wks, FileName, FileFormat, True)
  If Len(szSaved) Then MsgBox "File """ & szSaved & """ have been successfully saved!"
  Application.ScreenUpdating = True
End Sub
Hàm SaveSheet bạn không cần quan tâm, chỉ cần biết áp dụng tại sheet Main
Cú pháp hàm:
SaveSheet(Sheet cần lưu, Đường dẫn file sẽ lưu, kiểu định dạng file, cho lưu đè hay không?)
Lưu ý:
- Sheet cần lưu (Sheets2Save) có thể là 1 hoặc nhiều sheet
Ví dụ:
Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) ---> Lưu 2 sheet thành file
Set wks = ThisWorkbook.Worksheets("Sheet1") ---> Lưu 1 sheet duy nhất
- Đường dẫn file sẽ lưu (FileName2Save): Thư mục chứa đường dẫn đến file có thể đã tồn tại hoặc chưa. Nếu thư mục lưu file chưa tồn tại thì code sẽ tự động tạo ra nó
- kiểu định dạng file (FileFormat):
FileFormat = xlExcel8 <===> Đuôi file = "xls"​
​
FileFormat = xlOpenXMLWorkbook <===> Đuôi file = "xlsx"​
​
FileFormat = xlExcel12 <===> Đuôi file = "xlsb"​
​
FileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Đuôi file = "xlsm"​
- Cho lưu đè (OverWrite): OverWrite = TRUE sẽ cho lưu đè và ngược lại
-------------------
Vậy bạn chỉ cần quan tâm 3 dòng code màu đỏ và khai báo cho đúng là đủ
Nhấp chuột vào đây để mở rộng...
Set wks = ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) ---> Lưu 2 sheet thành file >> có hơi bị động vì phải thủ công nếu nhiều sheeet.
Nếu mình muốn bỏ qua không copy 1 số sheet , các sheet còn lại thì copy ., vậy chổ này Array thế nào anh NDU?
Em đã thử cho vào vòng lặp Forr để bỏ qua các sheet được đinh danh trước nhưng đến sub Main là code anh chỉ copy 1 sheet .
PS : Kỉ niệm 10 năm bài này nhưng vẫn còn hay và khả dụng.
Trân trọng
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

dungluyen2119
  • Question Question
Code VBA để tính tổng theo chiều ngang mà số cột không cố định (2 người xem)
Trả lời
4
Đọc
71
HUONGHCKT
H
D
Lọc cột chứa nhiều nhóm từ trong Excel. Mong các bạn giải đáp giúp (1 người xem)
Trả lời
7
Đọc
108
ptm0412
ptm0412
V
  • Question Question
Nhờ mọi người giúp cách xóa các mục đã chọn trong Droplist của một nhóm các ô cùng dạy một môn học.
Trả lời
2
Đọc
154
vinhphtdp
V
H
Câu lệnh mở file Excel trong Macbook Pro 1 (1 người xem)
Trả lời
0
Đọc
19
huafu_Jackl
H
N
Tạo COM Add-In bằng Visual C++
    • Thích
Trả lời
8
Đọc
740
nguyendang95
N
PhanTuHuong
Chương trình lập Báo cáo khảo sát Địa chất công trình GeoSection (1 người xem)
    • Thích
Trả lời
8
Đọc
6K
PhanTuHuong
PhanTuHuong
V
  • Question Question
Xác định xu hướng cấp 1,2,3 (2 người xem)
Trả lời
0
Đọc
24
vuthienfx
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
384
Đọc
45K
thanhluan0912
T
Nguyễn Duy Tuân
  • Question Question
AI muốn lập trình DLL cho Excel và các loại bằng Delphi thì xem video này nhé! (2 người xem)
    • Thích
    • Yêu thích
13 14 15
Trả lời
1K
Đọc
198K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
K
Tạo sheet tổng hợp
    • Cười
Trả lời
7
Đọc
315
SA_DQ
SA_DQ
V
Công thức để phân công chuyên môn cho giáo viên
Trả lời
9
Đọc
352
Hoàng Tuấn 868
H
Gà Con yêu VBA
Mở Pass file excel phiên bản .xlsx , xlsm, xlsb (1 người xem)
Trả lời
4
Đọc
129
befaint
befaint
V
  • Question Question
xác định xu hướng (2 người xem)
Trả lời
3
Đọc
133
vuthienfx
V
giaiphap
Lập trình C# tạo Add-ins cho excel.
    • Thích
Trả lời
52
Đọc
8K
nguyendang95
N
OverAC
  • Dán lên cao
  • Suggestion Suggestion
Chúc mừng sinh nhật GiaiPhapExcel 19 tuổi và tặng ebook "Lập trình VBA phần cơ bản."
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
7
Đọc
1K
PhanTuHuong
PhanTuHuong
Y
Lấy dữ liệu từ sheet chi tiết sang sheet tổng hợp hàng dọc
Trả lời
6
Đọc
588
yoomi
Y
E
Đánh số cho các cặp số chứng từ và số chứng từ đối ứng
Trả lời
16
Đọc
414
Phan Thế Hiệp
Phan Thế Hiệp
N
Hàm tính chuỗi số trong 1 ô hoặc 1 dãy ô ra tổng kết quả.
Trả lời
2
Đọc
127
minhminh27
minhminh27
NguyenthiH
Mở file Excel có Pass Open (1 người xem)
Trả lời
39
Đọc
3K
Hoàng Tuấn 868
H
M
Tách dữ liệu trong 1 file thành nhiều sheet theo số lượng dòng
    • Ngạc nhiên
Trả lời
25
Đọc
3K
Hoàng Tuấn 868
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom