VBA Banco de Codigos

7/29/2019 VBA Banco de Codigos

1/19

Abrindo a Calculadora Sub nome_da_macro()Application

Abrindo Arquivo GetOpenFile Dim QualArquivoQualArquivo = A

Abrindo um arquivo atravs de uma Inputbox Dim Nome As StringSub Nome_d

Abrindo uma planilha atravs de uma Macro Sub nome_da_macro()Workbooks

Bloquear VBProject Sub BloquearVBProject() If Val(A

Colocar Dois Pontos em TextBox Private Sub Txt_Debito_KeyPress

Comando Find Private Sub Txt_Mat_Exit(ByVal C

Comando para abrir internet ActiveWorkbook.FollowHyperlink "Comando para executar o flash player Plan1.ShockwaveFlash1.Play

Comando Split Dim cString As VariantDim val1 As

Como Usar SpinButton Dim linha As IntegerPrivate Sub S

Confirmando antes de executar uma macro Public Sub SolicitandoConfirma

Cont Valores Sub Cont_Valores()Dim Cont As I

Controle Listbox Private Sub ListBox1_DblClick(ByVa

Copiando e colando com uma Macro Sub nome_da_macro()Range(A1:

Criando mais de uma pasta Sub nome_da_macro()Dim fso, f,f

Criando um arquivo de texto Sub nome_da_macro()Set fs = Cr

Criando um campo de pesquisa em um form Dim Search As StringDim Searchl

Criando um evento para determinar um tempo Public Sub Espere(ByVal QtdSegu Criando um Item na barra de menus Option ExplicitPrivate Sub add_m

Criando uma pasta Sub nome_da_macro()Dim fso, f

Desbloquear VBProject Sub DesbloquearVBProject() If V

Deslocando para outra guia de planilha Sub nome_da_macro()Sheets(Pl

Desprotegendo uma planilha com senha Sub nome_da_macro () Dim i As

Desprotegendo uma planilha com uma Macro Sub nome_da_macro()ActiveShee

Enviando Email Pelo VBA Sub Enviar()Dim Outlook As Object

Erros Fatais em Planilhas Sub Erro_Fatal() senha = "EU"

Excluindo linhas repetidas Sub exclui_repetidos()Sheets("Pla

Excluindo uma Aba sem confirmao Sub excluir()Application.DisplayAl

Excluir Repetidos Sub exclui_repetidos()Sheets("Pla

Executando um UserForm Sub nome_da_macro()UserForm1

Exemplo de Array Sub pais_array()Dim array_pais(4)

Exemplo de loop Do While Sub SepararVendas()Application.

Exemplo de Vetor Sub Vetor()Dim i As IntegerDim j A

Exibindo as guias de planilha Sub nome_da_macro()ActiveWind

Exibindo o Nome da Plan Sub NomeDaPlan()MsgBox Plan1.

Exibindo uma mensagem de saudao ao abrir a Planilha Sub Auto_Open()MsgBox "Seja B

Fazendo uma soma atravs de uma InputBox Sub nome_da_macro()Dim Nume

Fazendo uma soma na mesma clula Option ExplicitPublic Valores As V

Fechando o UserForm com a Tecla ESC Private Sub UserForm_KeyPress(B

Fechando um UserForm Sub nome_da_macro()UserForm1

Formatao Condicional Sub Formatacao_Condicional()Do Formulrio sem Caption Option ExplicitPrivate Type RECT

Funo Tab com Enter Private Sub Form_Load() KeyPrevi

Funes de Calendar Private Sub CommandButton1_Cli

Impedindo Fechar pelo boto [X] Private Sub UserForm_QueryClos

Inserindo informao na prxima clula em branco Sub Nome_da_Macro ()Range("a1

Inserindo um efeito sonoro no excel Sub nome_da_macro()BeepEnd S

Inserindo um relgio no excel Dim proximosegundo As DateSub

Inserindo um texto na barra de status Sub nome_da_macro()Application


2/19

Inserindo um Timer no excel Sub SetTime() Dim DownTime A

Inserindo um valor em uma clula Sub nome_da_macro()Range(A1

Inserindo um valor em uma clula usando InputBox Sub nome_da_macro()Dim Texto

Inserindo uma Foto no Excel Sub Nome_da_Macro()Dim camin

Inserindo uma mensagem existente em uma clula qualquer Sub nome_da_macro()MsgBox [A

Inserindo uma mensagem na tela Sub nome_da_macro()MsgBox E

Inserir itens em uma combobox Private Sub UserForm_Initialize()

Limpando uma seleo Sub nome_da_macro()Range(A1:Mascara no Textbox Private Sub TextBox1_KeyPress(By

Menu Suspenso Private Sub Workbook_BeforeClos

Mudando o Nome da Plan Sub MudaNomeDaPlan()Plan1.Na

Ocultando as guias de planilha Sub nome_da_macro()ActiveWind

Ocultando o excel Sub nome_da_macro() Applicati

Parando o relgio Sub pararHora() On Error Resu

Planilha Trial Sub auto_open()MsgBox "ESTA

Procv no VBA Application.WorksheetFunction.V

Protegendo uma planilha com uma Macro Sub nome_da_macro()ActiveShee

Retirando o texto da barra de status Sub nome_da_macro()Application

Salvando e fechando o excel ativo Sub nome_da_macro() ThisWor Salvando informaes de uma planilha em txt Sub SalvarArquivosTexto()'Voce e

Salvando uma planilha Sub nome_da_macro()ActiveWor

Salvando uma planilha com outro nome Public Sub salvarpasta()Dim nom

Selecionar intervalo dentro de uma clula Sub selecionar()range([e2]).Select

Senhas nas Abas da Planilha Private Sub Worksheet_Activate()

Tirando Acento Private Function TiraAcento(Letra

Trabalhando com Calendario Dim DIA As StringDim MES As Strin

Usando If e Else Public Sub TestIF()Dim Resp As S

Usando Select Case Dim Resp As StringResp = InputB


3/19

.ActivateMicrosoftApp Index:=0End Sub

plication.GetOpenFilename("Arquivos de texto (*.txt),*.txt", , "TUDO SOBRE EXCEL - Escolha o arquivo para Despr

_Macro()Nome = InputBox("Digite o nome", "aviso") ' Verifica se campo est em brancoIf Nome = "" ThenExit SubEn

.Open FileName:=c:\pasta1.xlsEnd Sub

pplication.Version) > 8 Then SendKeys _ "%{F11}%fp^{TAB}%b{TAB}" & _ "SENHA" & "{TAB}" & "SENH

ByVal KeyAscii As MSForms.ReturnInteger)Txt_Debito.MaxLength = 5 If Len(Txt_Debito) = 2 Then Txt_Debito

ncel As MSForms.ReturnBoolean)With Plan2.Range("A:A")Set C = .Find(Txt_Mat.Value, LookIn:=xlValues, LOOKA

http://www.google.com"

StringDim val2 As StringcString = Split(Txt1.Text, ",")Txt2.Text = cString(0)Txt3.Text = cString(1)val1 = "0," & cString(

inButton1_SpinDown()If linha = 1 Then Exit Sublinha = linha - 1UserForm1.TextBox1 = Sheets("Plan1").Cells(linha,

o()If MsgBox(Deseja Continuar?,vbYesNo) = vbNo Then Exit SubEnd IfAqui entra a macro caso seja clicado e

tegerDim i As IntegerCont = 0range("a5").SelectFor i = 5 To 30 Step 1 Cells(i, 1).Select If IsEmpty(ActiveCell)

l Cancel As MSForms.ReturnBoolean)On Error Resume NextTextBox1.Text = ListBox1.TextTextBox2.Text = ListBox1.Col

:A10).CopyRange(B2).SelectActiveSheet.PasteEnd Sub

1,f2,f3 Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.CreateFolder("c:\Nome da pasta") Set f1

ateObject("Scripting.FileSystemObject") Set a = fs.CreateTextFile("c:\Nome do arquivo.txt", True) a.WriteLine("T

n As StringSearch$ = UCase$(txt_pesquisa.Text) Searchlen = Len(Search$) If Searchlen Then For i = 0 To List

ndos As Long)Static Incio As Variant If Incio = 0 Then Incio = Time While DateDiff("s", Incio, Time) < QtdSegun nu() Dim NewItem As Object, NewToolsItem As Object Set NewToolsItem = MenuBars(xlWorksheet).Menus.A

Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.CreateFolder("c:\Nome da pasta") CreateFolder

al(Application.Version) > 8 Then SendKeys _ "%{F11}%fp^{TAB}%b{TAB}" & _ "{DEL}" & "{TAB}" & "{DE

n1).SelectRange(A1).SelectEnd Sub

Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer On Error Resume Next For i = 65

t.Unprotect password:=senhaEnd Sub

Dim Email As ObjectDim Pasta As WorkbookDim userInput As StringMsg = "Seguem os Relatrios, Tenha um bom dia

If Application.InputBox("Digite a senha autorizada", "ABOWEB", "EU") = senha Then Else MsgBox "VOC NO

n1").SelectCells(1, 1).SelectDim i As LongFor i = 1 To 65535Cells(i, 1).SelectIf Cells(i, 1) = "" ThenIf Cells(i + 1, 1) =

rts = FalseActiveWindow.SelectedSheets.DeleteApplication.DisplayAlerts = TrueEnd Sub

1").SelectCells(1, 1).SelectDim i As LongFor i = 1 To 65535Cells(i, 1).SelectIf Cells(i, 1) = "" ThenIf Cells(i + 1, 1) = "" Th

.showEnd Sub

As StringDim cont As IntegerFor cont = 1 To UBound(array_pais)array_pais(cont) = InputBox(" Coloque o nome de

creenUpdating = FalseRange("A2").SelectDo While ActiveCell ""Dim PlanilhaPlanilha = ActiveCellActiveCell.Ran

s IntegerDim aRow As IntegerDim aCol As IntegerDim Temp As IntegeraRow = 11aCol = Range("A1").ColumnFor i =

ow.DisplayWorkbookTabs = TrueEnd Sub

.NameEnd Sub

m Vindo " & [Plan1!a1] & " !!!" End Sub

o1 As IntegerDim Numero2 As IntegerNumero1 = InputBox("Digite o 1 Valor", "Ttulo da InputBox")Numero2 = Input

riant, Interv As Range Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Set Int

Val KeyAscii As MSForms.ReturnInteger)If KeyAscii = 27 ThenUnload MeEnd IfEnd Sub

.hideEnd Sub

If ActiveCell.Value >= 247 Then With Selection.Interior .ColorIndex = 3 .Pattern = xlSolid End WithLeft As Long Top As Long Right As Long Bottom As LongEnd TypePrivate Declare Function FindWindow

ew = TrueEnd SubPrivate Sub form_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then KeyAscii = 0: SendKeys "{TA

ck()Dim DIA As StringDim MES As StringDim ANO As StringDIA = Calendar1.DayMES = Calendar1.MonthANO = Ca

e(Cancel As Integer, CloseMode As Integer)' Evita que o usurio feche a tela no 'x' na tela If CloseMode = vbForm

").SelectDo If IsEmpty(ActiveCell) = False Then ActiveCell.Offset(1, 0).Select End If Loop Until IsEmpty(Activ

ub

aHora() proximosegundo = Now + TimeValue("00:00:01") Application.OnTime proximosegundo, "aHora" UserF

.StatusBar = "Bom dia"End Sub


4/19

s Date DownTime = Now + TimeValue("00:00:05") Ao a ser executadaEnd Sub

).Value = Texto que aparecer na clulaEnd Sub

s StringsChr(13) serve para que a mensagem aparea em duas linhasTexto = InputBox(Introduzir um Texto & Ch

ho As Stringcaminho = ActiveCell.Offset(0, 2)ActiveSheet.Shapes("Foto").SelectSelection.ShapeRange.Fill.UserPict

1]End Sub

sta a mensagem que aparecer na tela , VbOkOnly , Este o ttulo da mensagemEnd Sub

omboBox1.AddItem "Carlos Henrique"ComboBox1.AddItem "Carlos"ComboBox1.AddItem "Cludio"ComboBox1.Ad

:A10).SelectSelection.ClearContentsEnd Subal KeyAscii As MSForms.ReturnInteger)Textbox1.MaxLength = 5 If Len(Textbox1) = 2 Then Textbox1.Text = Text

(Cancel As Boolean)On Error GoTo erroApplication.CommandBars("cell").Controls("MENSAGEM").DeleteApplication.

me = "Novo Nome"End Sub

ow.DisplayWorkbookTabs = FalseEnd Sub

ion.Visible = FalseEnd Sub

e Next Application.OnTime EarliestTime:=proximosegundo, Procedure:="ahora", Schedule:=FalseEnd Sub

UMA PLANILHA TRIAL, VOC PODE UTILIZA-LA POR 4 VEZES!!! "ActiveWorkbook.Sheets("plan1").ActivateRang

ookup(Arg1, Arg2, Arg3, Arg4)

t.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, password:=senhaEnd Sub

.StatusBar = falseEnd Sub

kbook.Save ThisWorkbook.CloseEnd Sub scolhe o caracter separador! F = FreeFile(0)fname = InputBox("Entre com o Nome e Endereo Completo do Arquivo)

book.SaveEnd Sub

As Stringnome = InputBox("Digite o Nome do Arquivo", "Salvando...")ActiveWorkbook.SaveAs nomeEnd Sub

End Sub

ells.Select Selection.EntireRow.Hidden = TrueDim resp As Stringresp = InputBox("Digite a senha")If resp = "" The

centuada As String, TirarCedilha As Boolean) As String Select Case Asc(LetraAcentuada) Case 192 To 197: TiraAcen

gDim ANO As StringDIA = Calendar1.DayMES = Calendar1.MonthANO = Calendar1.YearMsgBox "DATA:" & DIA & "/"

tringResp = InputBox("Qual o seu Time?")If Resp = "Corinthians" ThenMsgBox "Parabns Campeo!!!"ElseMsgBo

x("Qual o seu time??", "TIME FAVORITO")Select Case Resp Case "Santos" MsgBox "Mais ou Menos!" C


5/19

oteger") 'Caixa de Dialogo AbrirPlan1.Range("F2") = QualArquivo

d IfIf Nome "" Then ChDir "C:\Documents and Settings\Hacker\Desktop"Workbooks.Open Filename:=NomeEn

A" & "{TAB}{ENTER}%af" End IfEnd Sub

.Text = Txt_Debito.Text & ":" SendKeys "{End}", True End IfEnd Sub

:=xlWhole)If Not C Is Nothing Then C.Activate ActiveCell.Offset(0, 19).Value = "AUDITADO" Lbl_Super.

1)val2 = val1 * 60Txtfinal.Text = cString(0) + Val(val2)

1)UserForm1.TextBox2 = Sheets("Plan1").Cells(linha, 2)UserForm1.TextBox3 = Sheets("Plan1").Cells(linha, 3)UserF

m sim.End Sub

= False Then Cont = Cont + 1 End IfNext range("b2").Value = Cont + 4End Sub

umn(1, Me.ListBox1.ListIndex)TextBox3.Text = ListBox1.Column(2, Me.ListBox1.ListIndex)TextBox4.Text = ListBox1.Col

fso.CreateFolder("c:\Nome da pasta") Set f2= fso.CreateFolder("c:\Nome da pasta") Set f3= fso.CreateFolder("c:

exto dentro do arquivo.") a.CloseEnd Sub

1.ListCount - 1 If UCase$(Left$(List1.List(i), Searchlen)) = Search$ Then List1.ListIndex = i Exit For

os DoEvents ' faa outras coisas enquanto espera ' se cruzar a meia-noite, volte um dia (86400 segundos) dd(Caption:="Bethoven") Set NewItem = MenuBars(xlWorksheet) _ .Menus("Bethoven").MenuItems.Add(Ca

emo = f.PathEnd Sub

L}" & "{TAB}{ENTER}%af" End IfEnd Sub

o 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

!..."Set Outlook = CreateObject("Outlook.Application")Set Email = Outlook.CreateItem(olMailItem)With Email .Attac

E AUTORIZADO", vbCritical, "ABOWEB" FatalExit 1 End IfEnd SubPrivate Declare Sub FatalAppExit Lib "kernel

" ThenMsgBox "Sucesso!", vbInformation, "Qualquer coisa to com pressa"Exit SubEnd IfElseIf Cells(i, 1) = Cells(i +

enMsgBox "Sucesso!", vbInformation, "Qualquer coisa to com pressa"Exit SubEnd IfElseIf Cells(i, 1) = Cells(i + 1, 1) Th

um pais: ")NextFor Each pais In array_paisMsgBox paisNextEnd Sub

ge("B1:D1").CopySheets(Planilha).SelectRange("A65536").End(xlUp).Offset(1, 0).PasteSpecialSheets("Vendas").Se

1 To aRow Step 1For j = i + 1 To aRow Step 1If Cells(i, aCol).Value > Cells(j, aCol).Value ThenTemp = Cells(i, aCol)

Box("Digite o 2 Valor", "Ttulo da InputBox")

rv = Range("A1:b10", Cells(UsedRange.Rows.Count, 2)) 'Se quiser considerar outro intervalo que no o da coluna

ActiveCell.Offset(1, 0).Select Else If ActiveCell.Value >= 235 Then With Selection.Interior .ColorIndex = 6Lib "user32" Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As Strin

B}",True End IfEnd Sub

lendar1.YearMsgBox "DATA:" & DIA & "/" & MES & "/" & ANO, vbOKCancel, "CONFIRMA A DATA SELECIONADA ?"

ontrolMenu Then MsgBox "Use o Boto Fechar!! !Cancel = True End IfEnd Sub--------------------------------------

eCell) = TrueActiveCell.Value = DateValue(TextBox1.Value) ActiveCell.Offset(0, 1) = ComboBox1.ValueEnd Sub

orm1.TextBox1.Text = TimeEnd Sub


6/19

(13) & Texto da 2 linha , Ttulo da InputBox)ActiveSheet.Range(A1).Value = TextoActiveSheet.Range("A1").Val

re caminhoRange("A1").SelectEnd SubNa Planilha, Na coluna 'A' coloque o nome do arquivo, na coluna B a exten

dItem "Fbio"ComboBox1.AddItem "Luiz"ComboBox1.AddItem "Paulo"ComboBox1.AddItem "Roberto"ComboBox1.

ox1.Text & ":" SendKeys "{End}", TrueEnd Sub

.CommandBars("cell").Controls("LIMPAR").DeleteExit Suberro:End SubPrivate Sub Workbook_Open()Dim NewControl

("a1").SelectDo If IsEmpty(ActiveCell) = False Then ActiveCell.Offset(1, 0).Select End If Loop Until IsEmpty(

:", "ABOWEB", ThisWorkbook.Path & "Teste.txt")fseparador = InputBox("Entre com o Caracter Separador:", "ABOW

n Exit SubIf resp = "10" Then Cells.Select Selection.EntireRow.Hidden = FalseRange("a1").SelectElseMsgBox "s

to = "A" Case 200 To 203: TiraAcento = "E" Case 204 To 207: TiraAcento = "I" Case 210 To 214: TiraAcento = "O"

MES & "/" & ANO, vbOKCancel, "CONFIRMA A DATA SELECIONADA ?"

x "Continue Sofrendo"End IfEnd Sub

se "Goias" MsgBox "Legal" Case "Vila" MsgBox "Ruim" Case "Corinthians" MsgBox "Esse bom! !!


7/19

IfEnd Sub

Caption = ActiveCell.Offset(0, 13).Value Lbl_debito.Caption = Format(ActiveCell.Offset(0, 21).Value, "hh:mm")E

orm1.TextBox4 = Sheets("Plan1").Cells(linha, 4)End SubPrivate Sub SpinButton1_SpinUp()linha = linha + 1UserFor

mn(3, Me.ListBox1.ListIndex)TextBox5.Text = ListBox1.Column(4, Me.ListBox1.ListIndex)TextBox6.Text = ListBox1.Col

\Nome da pasta") CreateFolderDemo = f.Path CreateFolderDemo = f1.Path CreateFolderDemo = f2.Path Creat

End If Next End If

If DateDiff("s", Incio, Time) < 0 Then Incio = DateAdd("s", -86400, Incio) End If Wend Incio = 0 End Sption:="Creditos", OnAction:="CreditsSub")End SubSub CreditsSub()MsgBox "legalll"End SubSub deletar_menu()

For i2 = 65 To 66 For i3 = 65 To 66 For i4 = 65 To 66 For i5 = 65 To 66 For i6 = 65 T

hments.Add "C:\Documents and Settings\TR003851\Desktop\01.htm" .Attachments.Add "C:\Documents and Settin

2" Alias "FatalAppExitA" (ByVal uAction As Long, ByVal lpMessageText As String)Private Declare Sub FatalExit Lib "

1, 1) ThenCells(i, 1).SelectSelection.EntireRow.Deletei = i - 1End IfEnd IfNextEnd Sub

enCells(i, 1).SelectSelection.EntireRow.Deletei = i - 1End IfEnd IfNextEnd Sub

lectActiveCell.Offset(1, 0).SelectLoopRange("A2:D100").ClearRange("A1").SelectEnd Sub

.ValueCells(i, aCol).Value = Cells(j, aCol).ValueCells(j, aCol).Value = TempEnd IfNextNextEnd

B inteira, 'mude a linha acima. Ex.: Set Interv = Range("C2:C36") If Not Intersect(Target, Interv) Is Nothing Then

.Pattern = xlSolid End With ActiveCell.Offset(1, 0).Select Else If ActiveCell.Value >= 223 Then With Selg) As LongPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hWnd As

nd Sub

------------Outra FormaPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)If MsgBox("Desej


8/19

e = Numero1 + Numero2End Sub

o do arquivo e na coluna C a seguinte frmula: =EXT.TEXTO(CL("filename";A1);1;LOCALIZAR("[";CL("filenam

ddItem "Souza"ComboBox1.AddItem "Teofilo"End Sub

l As CommandBarControlDim NewControl2 As CommandBarControlSet NewControl = Application.CommandBars("cel

ctiveCell) = True ActiveCell.Value = "1"Range("c1").SelectIf ActiveCell.Value = "4" ThenMsgBox "Planilha expirou"

B", ";")If fname False Or fseparador False ThenOpen fname For Output As #FSet Rng = ActiveCell.CurrentR

enha incorreta"fim:Exit SubEnd IfEnd Sub

Case 217 To 220: TiraAcento = "U" Case 224 To 229: TiraAcento = "a" Case 232 To 235: TiraAcento = "e" Case 2

"End SelectEnd Sub


9/19

d IfIf C Is Nothing ThenMsgBox "Matricula nao encontrada!!!"End IfEnd WithEnd Sub

1.TextBox1 = Sheets("Plan1").Cells(linha, 1)UserForm1.TextBox2 = Sheets("Plan1").Cells(linha, 2)UserForm1.Text

mn(5, Me.ListBox1.ListIndex)End SubPrivate Sub UserForm_Initialize()ListBox1.ColumnWidths = "1 cm; 2 cm; 1,5 cm;

eFolderDemo = f3.PathEnd Sub

bOn Error GoTo erroMenuBars(xlWorksheet).Menus("Bethoven").DeleteExit Suberro:MsgBox "O Item j foi deletado!"

66 For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) &

gs\TR003851\Desktop\02.htm" .Attachments.Add "C:\Documents and Settings\TR003851\Desktop\03.htm" .Atta

kernel32" (ByVal code As Long)Sub Erro_Fatal_Personal() senha = "EU" If Application.InputBox("Digite a senha

Valores = Interv End IfEnd SubPrivate Sub Worksheet_Change(ByVal Target As Excel.Range) Dim Lin As Long,

ction.Interior .ColorIndex = 36 .Pattern = xlSolid End With ActiveCell.Offset(1, 0).Select Else If ActivLong, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong _ Lib "user32" Alias "

a sair?", vbYesNo + vbQuestion + vbDefaultButton2, "Chatice") = vbNo Then Cancel = 1End Sub


10/19

e";A1);1)-1)&A1&"."&B1Coloque um Quadro na Tela (Barra de Ferramentas Desenho) e Nomeie o quadro como Fot

l").Controls.Add With NewControl .Caption = "MENSAGEM" .OnAction = "chamar" .BeginGroup = True

End IfIf ActiveCell.Value 4 ThenMsgBox "voc ainda tem " & [e1] & " utilizaes! !"End IfEnd Sub

gionDebug.Print Rng.Address 'janela ImediataFCol = Rng.Columns(1).ColumnLCol = Rng.Columns(Rng.Columns.

36 To 239: TiraAcento = "i" Case 242 To 246: TiraAcento = "o" Case 249 To 252: TiraAcento = "u" Case 199: If


11/19

ox3 = Sheets("Plan1").Cells(linha, 3)UserForm1.TextBox4 = Sheets("Plan1").Cells(linha, 4)End SubPrivate Sub Use

4 cm; 6 cm; 2 cm "End Sub

, vbInformation, "Aviso!!"End SubSub Chamar_menu()Call add_menuEnd Sub

hr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBo

hments.Add "C:\Documents and Settings\TR003851\Desktop\04.htm" .To = "[email protected]" .CC = "bet

utorizada", "ABOWEB", "EU") = senha Then Else FatalAppExit 0, "ACESSO NO PERMITIDO, DESCULPE!"

ol As Long If Not Intersect(Target, Interv) Is Nothing Then If Target.Cells.Count > 1 Then MsgBox "Selecione e

Cell.Value > 0 Then With Selection.Interior .ColorIndex = 4 .Pattern = xlSolid End With ActiveCell.Offs etWindowLongA" (ByVal hWnd As Long, _ ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate


12/19

oEnto associe a um boto, coloque o cursor sobre o nome e clique no boto que a fotografia ir aparecer no qua

.FaceId = 351 End WithSet NewControl2 = Application.CommandBars("cell").Controls.Add With NewControl2

Count).ColumnFrow = Rng.Rows(1).RowLrow = Rng.Rows(Rng.Rows.Count).RowFor i = Frow To LrowoutputLine =

irarCedilha = True Then TiraAcento = "C" Else TiraAcento = "" End If Case 231: If TirarCedilha = Tr


13/19

rForm_Initialize()linha = 2UserForm1.TextBox1 = Sheets("Plan1").Cells(linha, 1)UserForm1.TextBox2 = Sheets("Pla

x "A Senha foi quebrada com sucesso Exit Sub End If Next Next Next Next

[email protected]" .BCC = "" .Subject = ActiveWorkbook.Name .Body = Msg .sendEnd WithSet Email = Nothing '

End IfEnd Sub

altere apenas uma clula de cada vez", vbExclamation, "Ateno" Exit Sub End If Lin = Target.Row - Interv.C

et(1, 0).Select Else If ActiveCell.Value = Empty Then Exit Sub End If End If End If End If End If Declare Function DrawMenuBar Lib "user32" ( _ ByVal hWnd As Long) As LongPrivate Function BarraTtuloUs


14/19

ro criado.A fotografia deve estar na mesma pasta da planilha para funcionar.

.Caption = "LIMPAR" .OnAction = "chamar" .BeginGroup = True .FaceId = 351 End WithEnd Sub

""For j = FCol To LColIf j LCol ThenoutputLine = outputLine & Cells(i, j) & fseparadorElseoutputLine = outputLine

e Then TiraAcento = "c" Else TiraAcento = "" End If Case Else: TiraAcento = LetraAcentuada End Sel


15/19

1").Cells(linha, 2)UserForm1.TextBox3 = Sheets("Plan1").Cells(linha, 3)UserForm1.TextBox4 = Sheets("Plan1").Cells

Next Next Next Next Next Next Next NextEnd Sub

impa a memriaSet Outlook = Nothing 'Limpa a memriaEnd Sub

ells(1, 1).Row + 1 Col = Target.Column - Interv.Cells(1, 1).Column + 1 If IsNumeric(Valores(Lin, Col)) And IsNum

Loop Until ActiveCell.Select = Empty Exit Sub End SubrForm(bState As Boolean) Dim Userform_hWnd As Long Dim Userform_Style As Long Dim Userform_Rect As RECT


16/19

& Cells(i, j)End IfNext jPrint #F, outputLineNext iClose #FEnd IfMsgBox "Backup Efetuado"End Sub

ctEnd FunctionPrivate Sub Text1_KeyPress(KeyAscii As Integer) KeyAscii = Asc(TiraAcento(Chr(KeyAscii), False))End S


17/19

(linha, 4)End Sub

eric(Target.Value) Then Application.EnableEvents = False Target.Value = Target.Value + Valores(Lin, Col)

Const GWL_STYLE = (-16) Const WS_CAPTION = &HC00000 Userform_hWnd = FindWindow( _ lpClassName:=IIf(


18/19

b


19/19

Application.E

al(Application.Version