MACROS PARA EXEL 1

 

Ativar Cx Dialogo Abrir

 Sub Abrir()

With Application

.Dialogs(xlDialogOpen).Show

End With

End Sub

 

Função que  acha o dia da Páscoa

 

Public Function calcularPascoa(ano)

    n1 = ano Mod 19

    n2 = Int(ano / 100)                                                                                                                                          

    n3 = ano Mod 100

    n4 = Int(n2 / 4)

    n5 = n2 Mod 4

    n6 = Int((n2 + 8) / 25)

    n7 = Int((n2 - n6 + 1) / 3)

    n8 = (19 * n1 + n2 - n4 - n7 + 15) Mod 30

    n9 = Int(n3 / 4)

    n10 = n3 Mod 4

    n11 = (32 + 2 * n5 + 2 * n9 - n8 - n10) Mod 7

    n12 = Int((n1 + 11 * n8 + 22 * n11) / 451)

   

    mes = Int((n8 + n11 - 7 * n12 + 114) / 31)

    dia = (n8 + n11 - 7 * n12 + 114) Mod 31

 

    calcularPascoa = DateSerial(ano, mes, (dia + 1))

 

End Function

 

 

Exibe um UserForm

Mudar frmUm  para o nome de seu Form

Sub ExibirForm()

frmUm.Show

End Sub

 

 

Sub ExibirForm()

UserForm2.Show

End Sub

 

Anexar Barra de Ferramenta

 Sub Anexar_Barra_Ferramentas()

With Application

.Dialogs(xlDialogAttachToolbars).Show

End With

End Sub

 

Caixa de Dialogo Auto correção

Sub Auto_Correção()

With Application

.Dialogs(xlDialogAutoCorrect).Show

End With

End Sub

 

Caixa

Sub Caixa()

Dim Numero, Valor, i, Soma As Integer

Soma = 0

Valor = 1

While (Valor = 1)

Numero = InputBox("Introduza um número:")

For i = 1 To Numero

Soma = Soma + i

Next i

MsgBox (" A soma dos primeiros  " & Numero & " números é " & Soma)

Resposta = MsgBox("Deseja continuar?", vbYesNo + vbQuestion)

If Resposta = vbYes Then

Valor = 1

Else

Valor = 0

End If

Wend

 End Sub

 

Ativa Calculadora

Sub ShowCalc()

    Shell "Calc.Exe", vbNormalFocus

End Sub

 

 Chama UserForm com duplo clic

 

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    UserForm1.Show

    Cancel = True

End Sub

 

Deletar linha especificada

Sub Deletar()

‘Para que esta macro funcione corretamente os códigos deverão conter Nº e letras

Dim cod As Variant

cod = InputBox("insira o código", "para Deletar a linha")

For i = 1 To 65536 Step 1

If Sheets("Plan2").Cells(i, "A") = cod Then

For j = 1 To 25 Step 1 ‘Alterar colunas To ?

Sheets("Plan2").Cells(i, j) = ""

Next j

End If

Next i

 

End Sub

 

DADOS DUPLICADOS

Option Explicit

 

'Objetivo :  Verificar valores duplicados

 

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim nLinComp, nLinFim  As Integer ' Declara nLinha com Inteiro

If ActiveCell.Column = 1 Then ' só funciona na coluna 1

    nLinFim = 1 ' Define qual é linha onde inicia-se os dados para achar i final da lista

   

    Do While Not IsEmpty(Cells(nLinFim, 1)) ' Faça enquanto não for vazia as células de valores informado

        nLinFim = nLinFim + 1  ' Incrementa uma linha para baixo

    Loop  ' Faz o Loop

   

    nLinComp = 1 'Define qual é linha que inicia-se os dados para comparação

    Do While nLinComp <= nLinFim - 2 ' Faça enquanto conter valores informado

        If Cells(nLinFim - 1, 1).Value = Cells(nLinComp, 1).Value Then  ' Caso o último valores informado for igual ao valores em comparação então...

            MsgBox "valores duplicado", vbCritical, "Cadastro valores !" 'Exibe uma mensagem

            Cells(nLinFim - 1, 1).Activate 'Ativa o valores em duplicidade

            Cells(nLinFim - 1, 1).Interior.ColorIndex = 4 ' Formata o interior da célula em verde

            Exit Sub ' Finaliza Código

        Else ' Senão

            nLinComp = nLinComp + 1 ' Vai para o próximo valores da lista

        End If ' Finaliza IF

    Loop ' Faz o Ciclo

    Cells(nLinComp + 1, 1).Activate ' Não achando duplicidade, ativa a próxima célula

    If nLinFim > 1 Then Cells(nLinFim - 1, 1).Interior.ColorIndex = xlNone ' Retira o formato do interior da célula em verde, caso conter

    If nLinFim > 1 Then Cells(nLinFim, 1).Interior.ColorIndex = xlNone  ' Retira o formato do interior da célula em verde, caso conter

End If

End Sub ' Encerra o código

 

 

CX DIALOGO PROTEGER

Sub Proteger_Planilha()

With Application

.Dialogs(xlDialogProtectDocument).Show

End With

End Sub

 

CX DIALOGO IMPRESSORA

Sub Impressora()

With Application

.Dialogs(xlDialogPrint).Show

End With

End Sub

CX DIALOGO DESPROTEGER PLANILHA

Sub Desproteger_Planilha()

ActiveSheet.Unprotect 'desprotege a planilha

End Sub

 

CX DIALOGO BORDAS

Sub CxDialogo_Bordas()

With Application

.Dialogs(xlDialogBorder).Show

End With

End Sub

 

 COPIA FIGURA

Sub Copiar_Figura()

With Application

.Dialogs(xlDialogCopyPicture).Show

End With

End Sub

Sub ConverterMaiuscula()

       Dim n As Range

 

       For Each n In Selection

              n.Value = UCase(n.Value)

       Next

End Sub

 

CONVERTER MINÚSCULA

Sub ConverterMinuscula()

       Dim n As Range

 

       For Each n In Selection

              n.Value = LCase(n.Value)

       Next

End Sub

 CONVERTER MAIÚSCULA

Sub ConverterPriMaiuscula()

       Dim n As Range

       For Each n In Selection

              n.Value = StrConv(n.Value, vbProperCase)

       Next

End Sub

 

 CONVERTER EM DOLAR

 Sub Converter_R_US()

    Dim Linha As Long

    Dim Coluna As String

    Dim Valor As Double

    Dim Cotacao As Double

   

    Coluna = "h"

    Linha = 7

    Valor = Cells(Linha, Coluna)

    Cotacao = InputBox("Digite a cotação do Dólar, 1US$ = R$: ", "Cotação")

    While Cells(Linha, Coluna) <> ""

        Valor = Cells(Linha, Coluna)

        Cells(Linha, Coluna) = Valor * Cotacao

        Linha = Linha + 1

    Wend

End Sub

 

FUNÇÃO NOME CONTRÁRIO

Public Function Contrario(Campo As String)

    Dim contador As Integer

    For contador = 1 To Len(Campo)

        Contrario = Contrario & Mid(Right(Campo, contador), 1, 1)

    Next contador

End Function

 

CX DIALOGO CONF PG

Sub Configurar_Página()

With Application

.Dialogs(xlDialogPageSetup).Show

End With

End Sub

 

 EXIBIR  FORM

Option Explicit

 Sub ExibirForm()

UserForm1.Show

End Sub

  

DESPROTEGER PLANILHA

Option Explicit

Sub DesprotegerPlanilhaAtiva()

Dim i, i1, i2, i3, i4, i5, i6 As Integer, j As Integer, k As Integer, _

l As Integer, m As Integer, n As Integer

On Error Resume Next

For i = 65 To 66

For j = 65 To 66

For k = 65 To 66

For l = 65 To 66

For m = 65 To 66

For i1 = 65 To 66

For i2 = 65 To 66

For i3 = 65 To 66

For i4 = 65 To 66

For i5 = 65 To 66

For i6 = 65 To 66

For n = 32 To 126

ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) _

& Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

If ActiveSheet.ProtectContents = False Then

MsgBox "Planilha desprotegida com sucesso!!!"

Exit Sub

End If

Next

Next

Next

Next

Next

Next

Next

Next

Next

Next

Next

Next

End Sub

 

 

Exibir hora

 Sub Exibe_Data_Hora()

mes_atual = Month(Date)

mes_nome = MonthName(mes_atual, False)

mensagem = "Ano atual: " & Year(Date) & Chr(13)

mensagem = mensagem & "Mês atual: " & mes_nome & Chr(13)

mensagem = mensagem & "Hoje é dia: " & Day(Date) & Chr(13)

mensagem = mensagem & Chr(13) & "***************" & Chr(13) & Chr(13)

hora_atual = Hour(Time())

minuto_atual = Minute(Time())

secundo_atual = Second(Time())

mensagem = mensagem & "Hora atual: " & hora_atual & Chr(13)

mensagem = mensagem & "Minuto atual: " & minuto_atual & Chr(13)

mensagem = mensagem & "Secundo atual: " & secundo_atual

MsgBox mensagem

End Sub