Code save as sheet hiện hành

[pro8x]

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

 

[vanhesing]

Code cho bạn đây:

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

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à đủ

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