Gerar Excel Completo via VBScript

[Anonymous]

Sub gerarExcel()

Dim XLApp, XLDoc, XLSheet, VersaoRelatorio
'XLApp = Aplicação -- XLDoc = Workbook(Pasta de Trabalho) -- XLSheet = Worksheet(Folha/Aba/Planilha)
Dim qColunas, qLinhas, Cell, Sheet, Caminho
'qColunas = Número de Colunas Preenchidas -- Qlinhas = Número de Linhas Preenchidas
'Caminho = Lugar para o arquivo ser salvo - Sheet = Worksheet(Folha/Aba/Planilha) - Cell = Objeto Cells

Set XLApp = CreateObject("Excel.Application")
'Inicializa uma aplicação - Objeto Chave: Application
Set XLDoc = XLApp.Workbooks.Add
'Cria uma nova pasta de trabalho - Objeto Chave: Workbook
Set XLSheet = XLDoc.Worksheets(1)
'Entra na primeira guia - Objetos Chaves: Worksheet/Sheet

'On Error Resume Next
'Caso der erro o código continua, caso contrário ele abre o executor de macros

XLApp.Visible = True
'Torna a aplicação visível

XLDoc.Application.Range("C3").Value = "Estamos preparando tudo para você!"
XLDoc.Application.Range("C4").value = "Por favor, aguarde e não desligue o computador ou feche o programa"
'Caso queira deixar uma mensagem enquanto o código é executado por trás para fazer o usuário não mecher enquanto o código não finaliza

XLApp.Cursor = XlWait
'Deixa o mouse com icone de 'Carregando' para o usuário saber que está executando

XLSheet.Application.ScreenUpdating = False
'Paraliza a tela para o usuário não ver a planilha sendo feita

For Each Sheet In Xldoc.Worksheets

IF Sheet.Name <> XLSheet.Name Then

'Sheet.delete 'Delete
'Sheet.visible = 2 'Oculta

End If

Next
'Deixa apenas uma aba que é a que você está manipulando (por padrão o excel criar 3 abas)

XLApp.Cells.Select
XLApp.ActiveWindow.DisplayGridlines = False
'Tira todas as linhas de grade

XLDoc.Application.Range("A3").Select
'Seleciona a célula onde vai ser colada a tabela

ActiveDocument.GetSheetObject("CH06").CopyTableToClipBoard TRUE
XLSheet.Paste
'Copia a tabela e cola na célula selecionada

qLinhas = XLSheet.UsedRange.Rows.Count + 2
qColunas = XLSheet.UsedRange.Columns.Count
'Guarda quantas colunas e linhas estão preenchidas

XLApp.Columns(Left(Replace(Replace(XLApp.Columns(qColunas + 1).Address, "$", ""), ":", ""), Len(Replace(Replace(XLApp.Columns(qColunas + 1).Address, "$", ""), ":", "")) / 2) & ":XFD").EntireColumn.Hidden = True
XLApp.Rows(qLinhas + 1 & ":1048576").EntireRow.Hidden = True
'Seleciona todas as colunas e linhas não selecionadas e oculta

XLApp.Rows("1:" & qLinhas).RowHeight = 30
XLSheet.UsedRange.EntireColumn.AutoFit
'Seleciono as linhas usadas e colo no tamanho 30, depois seleciono as colunas e deixo elas terem o tamanho que precisarem

XLApp.Range("A1:" & Left(Replace(Replace(XLApp.Columns(qColunas).Address, "$", ""), ":", ""), Len(Replace(Replace(XLApp.Columns(qColunas).Address, "$", ""), ":", "")) / 2) & "1").Merge
XLDoc.Application.Range("A1").Value = "RELATÓRIO GERADO ATRAVÉS DO SISTEMA ... "
XLDoc.Application.Cells(qLinhas + 1, qColunas).value = "Feito por: "
'Coloco o título e o rodapé


For Each Cell In XLApp.Range("A1:" & Left(Replace(Replace(XLApp.Columns(qColunas).Address, "$", ""), ":", ""), Len(Replace(Replace(XLApp.Columns(qColunas).Address, "$", ""), ":", "")) / 2) & "1")

If Cell.ColumnWidth > 80 Then

Cell.ColumnWidth = 80

ElseIf Cell.ColumnWidth < 10 Then

Cell.ColumnWidth = 10

End If

Next
'Vou em todas colunas para nenhuma ser menor que 10 ou maior que 80

XLSheet.Name = "Relatório"
'Troco o nome da aba

XLApp.Cursor = XLDefault
'Deixa o mouse com icone normal de novo

XLSheet.Application.ScreenUpdating = true
'Libera a tela

IF msgbox("Relatório Gerado com Suceso" & VbCrlf & "Gostaria de Salvar a Planilha Gerada?", VbQuestion + VbYesNo, "Título") = VbYes THEN
'Pergunta se quer salvar

Caminho = inputbox("Insira o local de armazenamento completo sem o nome do arquivo", "Título", _
"C:\Windows\Temp")
'Pede o caminho

Err.Number = 0 'Zera o número de erros

XLDoc.SaveAs cstr(Caminho) & "\Planilha" , 51
'Salva como xlsx

If Err.Number <> 0 Then
'Verifica se deu erro durante a execusão

MsgBox "Erro no salvamento" & vbcrlf & "Por favor, entre em contato com o Projetos", vbexclamation, "Título"
'Avisa

Else

Msgbox "Salvo com sucesso", VbInformation, "Título"

End if

End If

End Sub