Códigos Úteis em VBA

1. Atualizar Tabelas Dinâmicas (versão 1)

'Dimensionar variáveis
    Dim pt As PivotTable
    Dim ws As Worksheet

'Atualiza Pivot Tables uma a uma
    For Each ws In ActiveWorkbook.Worksheets
        For Each pt In ws.PivotTables
           pt.RefreshTable
          Next pt
       Next ws

2. Atualizar Tabelas Dinâmicas (versão 2)

ActiveWorkbook.RefreshAll

3. Tela Cheia e Tela Normal

Sub Apresentar_on()
Application.ExecuteExcel4Macro "SHOW.Toolbar(""Ribbon"", False)" 'Oculta todas as guias de menu
Application.DisplayFormulaBar = False 'Ocultar barra de fórmulas
Application.DisplayStatusBar = False 'Ocultar barra de status, disposta ao final da planilha

With ActiveWindow
.DisplayWorkbookTabs = False 'Ocultar guias das planilhas
.DisplayHeadings = False 'Oculta os títulos de linha e coluna
End With
End Sub

Sub Apresentar_off()
Application.ExecuteExcel4Macro "SHOW.Toolbar(""Ribbon"", True)" 'Reexibir todas as guias de menu
Application.DisplayFormulaBar = True 'Reexibir barra de fórmulas
Application.DisplayStatusBar = True 'Reexibir barra de status, disposta ao final da planilha

With ActiveWindow
.DisplayWorkbookTabs = True 'Reexibir guias das planilhas
End With
End Sub

4. Impressão em PDF

Sub Impressao_pdf()


Sheets("Tabelas Dinâmicas").Range("A1").FormulaR1C1 = "=YEAR(TODAY())&MONTH(TODAY())&DAY(TODAY())&""-""&HOUR(NOW())&MINUTE(NOW())"
NOME = Sheets("Planilha").Range("A1").Value

    Sheets(Array("Planilha1", "Planilha2", "Planilha3", "Planilha4")).Select
    Sheets("Planilha1").Activate
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "C:\Users\Adm\Desktop\Curso_Avançado\Exercícios Dominando Dashboards\Dashboards_" & NOME & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=True
    Sheets("Planilha").Select
End Sub

5. Aparecer e Sumir Imagem

Sheets("Planilha").Shapes("Imagem").Visible = False 'Sumir uma imagem

Sheets("Planilha").Shapes("Imagem").Visible = True 'Aparecer uma imagem

6. Atualização da tela

Application.ScreenUpdating = False      'Para a atualização - coloque no início
Application.ScreenUpdating = True      'Libera a atualização - coloque no final

7. Bloqueio

'Bloquear a planilha senha teste
    Sheets("Planilha").Protect "teste"

'Desbloquear a planilha senha teste
    Sheets("Planilha").Unprotect "teste"

'Bloquear a planilha tabelas
    Sheets("Tabelas Dinâmicas").Protect AllowUsingPivotTables:=True, Password:="teste"

8. Chamar outra macro

Call macro

9. Mostrar uma mensagem

Sub mensagens()

MsgBox "Sua mensagem aqui!"
MsgBox "Mensagem1" + vbCrLf + "Mensagem 2", vbYesNo, "Título"
MsgBox "Mensagem1" + vbCrLf + "Mensagem 2", vbInformation, "Título"
End Sub

'vbOKOnly: Exibe apenas o botão OK
'vbOKCancel: Exibe os botões OK e Cancelar
'vbAbortRetryIgnore: Exibe os botões Abortar, Repetir  e Ignorar
'vbYesNoCancel: Exibe os botões Sim, Não e Cancelar
'vbYesNo: Exibe os botões Sim e Não
'vbRetryCancel: Exibe os botões Repetir e Cancelar

'vbCritical: Exibe o ícone Mensagem Crítica
'vbQuestion: Exibe o ícone Consulta de Aviso
'vbExclamation: Exibe o ícone Mensagem de Aviso
'vbInformation: Exibe o ícone Mensagem de Informação

10. Zoom Automático

Range("tela").Select
ActiveWindow.Zoom = True

11. Condição (If)

If a = 1 Then 'Teste lógico
'O que vai acontecer se verdadeiro
Else
'O que vai acontecer se falso
End If

12. Condição (Case)

X = range("A1").value 'Variável que será testada 

Select Case X 
Case 1 To 5    'Se X for igual a 1, 2, 3, 4 ou 5 
    Msgbox "Está entre 1 e 5"
 
Case 6, 7, 8    'Se X for igual a 6, 7 ou 8  
    Msgbox "Está entre 6 e 8"

Case 9    'Se X for igual a 9 
    Msgbox "É igual a 9"
Case Else    ' Outros valores 
    Debug.Print "O valor não está entre 1 e 9" 
End Select

13. Encerrar a macro

Exit Sub

14. Carregar Imagem sem Erro

Private Sub CommandButton1_Click()
fotopasta = Application.GetOpenFilename '(FileFilter:="Image Files(*.jpg), *.jpg")
If fotopasta <> False Then Image1.Picture = LoadPicture(fotopasta)
End Sub

15. Enviar e-mail com anexos

Private Sub CommandButton1_Click()

If CheckBox1 = True Then
Call ANEXO_CADASTRO
ANEXO1 = "C:\Relatoriodiario\Informação_do_dia.pdf"
Else
ANEXO1 = ""
End If

If CheckBox2 = True Then
Call ANEXO_CALCULADORA
ANEXO2 = "C:\Relatoriodiario\Calculadora.pdf"
Else
ANEXO2 = ""
End If

If CheckBox3 = True Then
Call ANEXO_PAINEL
ANEXO3 = "C:\Relatoriodiario\Dashboard.pdf"
Else
ANEXO3 = ""
End If

If CheckBox4 = True Then
Call ANEXO_SELIGA
ANEXO4 = "C:\Relatoriodiario\SeLiga.pdf"
Else
ANEXO4 = ""
End If

Set objeto_outlook = CreateObject("Outlook.Application")
Set email_envio = objeto_outlook.createitem(0)

With email_envio

.to = TextBox4.Value
.cc = TextBox5.Value
.bcc = ""
.Subject = TextBox6.Value
.htmlbody = TextBox7.Value

If ANEXO1 <> "" Then
    .attachments.Add ANEXO1
End If

If ANEXO2 <> "" Then
    .attachments.Add ANEXO2
End If

If ANEXO3 <> "" Then
    .attachments.Add ANEXO3
End If

If ANEXO4 <> "" Then
    .attachments.Add ANEXO4
End If

email_envio.Send
End With
MsgBox "Email Enviado"

Unload Me

End Sub

Private Sub UserForm_Click()

End Sub

16. Looping Objetos do Formulário

for each OBJ in UserForm.Controls
if obj.Tag = "nome" then
next obj

17. Tratamento de Erros

On Error Resume Next 'Em caso de erro, continue o código

On error goto line0 'Em caso de erro, vá para line0

18. Salvar na Mesma Pasta

Thisworkbook.path