Salve Planilhas com o VBA - Parte 02 - Da versão 2007 à 2016 - Use VBA SaveAs in Excel 2007-2016

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

✔ Brazil SFE®Author´s Profile  Google+   Author´s Professional Profile   Pinterest   Author´s Tweets

Nenhum comentário:

Postar um comentário

diHITT - Notícias