Salve Planilhas com o VBA - Parte 02 - Da versão 2007 à 2016 - Use VBA SaveAs in Excel 2007-2016
Abaixo estão 2 exemplos de código VBA que copiam a ActiveSheet para uma nova pasta de trabalho, salvando-a num formato que corresponda à extensão da planilha pai. O segundo exemplo usa GetSaveAsFilename solicitando um caminho e o nome do arquivo.
Este 1º Exemplo você pode usar nas versões Excel 97-2016, o 2º exemplo pode ser usado nas versões Excel 2000-2016.
Se você executar o código no Excel 2007-2016 ele tomará como referência o FileFormat da planilha pai, salvando o novo arquivo neste formato. Apenas se a planilha pai for um arquivo xlsm e se não houver nenhum código VBA na nova planilha, é que ela salvará o novo arquivo como xlsx. Se a planilha pai não for um xlsx, xlsm ou xls, em seguida será salva como xlsb.
Se você sempre salvar num determinado formato que possa substituir esta parte da macro:
Select Case Sourcewb.FileFormat
Caso 51: FileExtStr = ".xlsx": FileFormatNum = 51
Caso 52:
Se .HasVBProject Então
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Caso 56 : FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
Use um destes desta lista
- FileExtStr = ".xlsb": FileFormatNum = 50
- FileExtStr = ".xlsx": FileFormatNum = 51
- FileExtStr = ".xlsm": FileFormatNum = 52
Ou talvez queira salvar como csv, txt ou prn.
(também pode usar estes nas versões 97-2003 do Excel)
- FileExtStr = ".csv": FileFormatNum = 6
- FileExtStr = ".txt": FileFormatNum = -4158
- FileExtStr = ".prn": FileFormatNum = 36
Outros examplos
Sub Copy_ActiveSheet_1()
'Trabalhando com o Excel 97-2016
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End 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 it
TempFilePath = 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:=False
End With
MsgBox "You can find the new file in " & TempFilePath
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub Copy_ActiveSheet_2()
'Working in Excel 2000-2016
Dim fname As Variant
Dim NewWb As Workbook
Dim FileFormatValue As Long
'Check the Excel version
If Val(Application.Version) < 9 Then Exit Sub
If Val(Application.Version) < 12 Then
'Only choice in the "Save as type" dropdown is Excel files(xls)
'because the Excel version is 2000-2003
fname = 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 workbook
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
'We use the 2000-2003 format xlWorkbookNormal here to save as xls
NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End If
Else
'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 list
fname = 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" list
If fname <> False Then
Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
Case "xls": FileFormatValue = 56
Case "xlsx": FileFormatValue = 51
Case "xlsm": FileFormatValue = 52
Case "xlsb": FileFormatValue = 50
Case Else: FileFormatValue = 0
End Select
'Now we can create/Save the file with the xlFileFormat parameter
'value that match the file extension
If FileFormatValue = 0 Then
MsgBox "Sorry, unknown file extension"
Else
'Copies the ActiveSheet to new workbook
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
'Save the file in the format you choose in the "Save as type" dropdown
NewWb.SaveAs fname, FileFormat:= _
FileFormatValue, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End If
End If
End If
End Sub
brazilsalesforceeffectiveness@gmail.com
Nenhum comentário:
Postar um comentário