Select Case Sourcewb.FileFormatCase 51: FileExtStr = ".xlsx": FileFormatNum = 51Case 52:If .HasVBProject ThenFileExtStr = ".xlsm": FileFormatNum = 52ElseFileExtStr = ".xlsx": FileFormatNum = 51End IfCase 56: FileExtStr = ".xls": FileFormatNum = 56Case Else: FileExtStr = ".xlsb": FileFormatNum = 50End Select
Sub Copy_ActiveSheet_1()'Working in Excel 97-2010Dim FileExtStr As StringDim FileFormatNum As LongDim Sourcewb As WorkbookDim Destwb As WorkbookDim TempFilePath As StringDim TempFileName As StringWith Application.ScreenUpdating = False.EnableEvents = FalseEnd WithSet Sourcewb = ActiveWorkbook'Copy the sheet to a new workbookActiveSheet.CopySet Destwb = ActiveWorkbook'Determine the Excel version and file extension/formatWith DestwbIf Val(Application.Version) < 12 Then'You use Excel 97-2003FileExtStr = ".xls": FileFormatNum = -4143Else 'You use Excel 2007-2010'We exit the sub when your answer is NO in the security dialog that you'only see when you copy a sheet from a xlsm file with macro's disabled.If Sourcewb.Name = .Name ThenWith Application.ScreenUpdating = True.EnableEvents = TrueEnd WithMsgBox "Your answer is NO in the security dialog"Exit SubElseSelect Case Sourcewb.FileFormatCase 51: FileExtStr = ".xlsx": FileFormatNum = 51Case 52:If .HasVBProject ThenFileExtStr = ".xlsm": FileFormatNum = 52ElseFileExtStr = ".xlsx": FileFormatNum = 51End IfCase 56: FileExtStr = ".xls": FileFormatNum = 56Case Else: FileExtStr = ".xlsb": FileFormatNum = 50End SelectEnd IfEnd IfEnd With ' 'Change all cells in the worksheet to values if you want' With Destwb.Sheets(1).UsedRange' .Cells.Copy' .Cells.PasteSpecial xlPasteValues' .Cells(1).Select' End With' Application.CutCopyMode = False'Save the new workbook and close itTempFilePath = Application.DefaultFilePath & "\"TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")With Destwb.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum.Close SaveChanges:=FalseEnd WithMsgBox "You can find the new file in " & TempFilePathWith Application.ScreenUpdating = True.EnableEvents = TrueEnd WithEnd SubSub Copy_ActiveSheet_2()'Working in Excel 2000-2010Dim fname As VariantDim NewWb As WorkbookDim FileFormatValue As Long'Check the Excel versionIf Val(Application.Version) < 9 Then Exit SubIf Val(Application.Version) < 12 Then 'Only choice in the "Save as type" dropdown is Excel files(xls)'because the Excel version is 2000-2003fname = Application.GetSaveAsFilename(InitialFileName:="", _filefilter:="Excel Files (*.xls), *.xls", _Title:="This example copies the ActiveSheet to a new workbook")If fname <> False Then'Copy the ActiveSheet to new workbookActiveSheet.CopySet NewWb = ActiveWorkbook'We use the 2000-2003 format xlWorkbookNormal here to save as xlsNewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=FalseNewWb.Close FalseSet NewWb = NothingEnd IfElse 'Give the user the choice to save in 2000-2003 format or in one of the'new formats. Use the "Save as type" dropdown to make a choice,Default ='Excel Macro Enabled Workbook. You can add or remove formats to/from the listfname = Application.GetSaveAsFilename(InitialFileName:="", filefilter:= _" Excel Macro Free Workbook (*.xlsx), *.xlsx," & _" Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _" Excel 2000-2003 Workbook (*.xls), *.xls," & _" Excel Binary Workbook (*.xlsb), *.xlsb", _FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")'Find the correct FileFormat that match the choice in the "Save as type" listIf fname <> False ThenSelect Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))Case "xls": FileFormatValue = 56Case "xlsx": FileFormatValue = 51Case "xlsm": FileFormatValue = 52Case "xlsb": FileFormatValue = 50Case Else: FileFormatValue = 0End Select 'Now we can create/Save the file with the xlFileFormat parameter'value that match the file extensionIf FileFormatValue = 0 ThenMsgBox "Sorry, unknown file extension"Else'Copies the ActiveSheet to new workbookActiveSheet.CopySet NewWb = ActiveWorkbook'Save the file in the format you choose in the "Save as type" dropdownNewWb.SaveAs fname, FileFormat:= _FileFormatValue, CreateBackup:=FalseNewWb.Close FalseSet NewWb = NothingEnd IfEnd IfEnd IfEnd Sub
联系客服