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
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
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
Vâng e xin cảm ơn.hi hi
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 FunctionSub 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 SubEm xin cảm ơn thầy đã giúp. Còn 1 vấn đề em muốn hỏi mong thầy giúp
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 SubBạn muốn save sheet hiện hành thì: Set wks = ActiveSheet thôi là được rồi chứ gì
Ah thầy ơi ý e là thế này.
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
Vâng mong thầy chỉ thêm về vấn đề này ah
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 SubPrivate Sub Auto_Close()
DelBar
End SubPrivate Sub ShowHelp()
Dim dlg As DialogSheet
Set dlg = ThisWorkbook.DialogSheets("Help")
dlg.Show
End SubPrivate 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 SubPrivate Sub DelBar()
On Error Resume Next
Application.CommandBars("Save Sheets").Delete
End SubPrivate 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 SubPrivate 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 SubPrivate 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 SubPrivate 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 SubPrivate 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
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
