A macro preserva a planilha atual sem alterações (salvar como automático)
Ações:
- Copiar somente valores das planilhas selecionadas
- Deletar as outras planilhas do arquivo
- Salvar PDF com múltiplas páginas, na mesma pasta do arquivo (nome com UNDERLINE na frente)
- Salvar como EXCEL, na mesma pasta do arquivo (nome com UNDERLINE na frente)
Exigências:
- Selecionar as abas das planilhas de interesse antes de executar a macro
Como "instalar" na planilha:
- copiar o conteúdo da caixa abaixo
- Desenvolvedor > Macros > Inserir > Módulo > [Colar Conteúdo]
Sub gerarPDF()
'Contar quantidade de planilhas selecionadas
Dim n As Integer
n = ActiveWindow.SelectedSheets.Count
'MsgBox "Número de planilhas selecionadas é " & n 'Verificação qtde de planilhas selecionadas
'Copiar somente valores das planilhas selecionadas
Dim planSelecionadas() As String
ReDim planSelecionadas(n) 'redimensionar o array conforme número de linhas desejado
Dim sh1 As Object
Dim i As Integer
i = 0
For Each sh1 In ActiveWindow.SelectedSheets
'Salvar nome da planilha na lista planSelecionadas
planSelecionadas(i) = sh1.Name
'MsgBox planSelecionadas(i) 'verificação do valor atribuido
'Copiar valores das planilhas selecionadas
Sheets(planSelecionadas(i)).Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
i = i + 1 'próximo item da lista
Next sh1
'Deletar as outras planilhas do arquivo
Dim sh2 As Object
Dim deletar As Boolean
Application.DisplayAlerts = False 'desabilitar alertas do excel que impedem deletar a aba atual
For Each sh2 In ActiveWorkbook.Sheets
deletar = True 'inicia com deletar verdadeiro
'MsgBox sh2.Name 'verificação passagem de planilhas
'Verificar se a planilha atual está entre as selecionadas
For i = 0 To (n - 1) 'posição inicial do For é 0
If sh2.Name = planSelecionadas(i) Then
deletar = False
End If
Next i
If deletar = True Then
Sheets(sh2.Name).Select
ActiveSheet.Delete
End If
Next sh2
Application.DisplayAlerts = True 'habilitar alertas do excel que impedem deletar a aba atual
ActiveWorkbook.Sheets.Select 'selecionar todas as planilhas
'Salvar PDF, na mesma pasta do arquivo
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ActiveWorkbook.Path & "\_" & Mid(ActiveWorkbook.Name, 1, InStrRev(ActiveWorkbook.Name, ".") - 1) _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
'Salvar como EXCEL, na mesma pasta do arquivo
ActiveWorkbook.SaveAs Filename:= _
ActiveWorkbook.Path & "\_" & ActiveWorkbook.Name _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'Selecionar apenas a primeira célula da primeira planilha do arquivo
Sheets(1).Select
Range("A1").Select
End Sub