View
234
Download
0
Category
Preview:
Citation preview
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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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 = "bethoven07@gmail.com" .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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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
ovenx@msn.com" .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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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
7/29/2019 VBA Banco de Codigos
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(
7/29/2019 VBA Banco de Codigos
18/19
b
7/29/2019 VBA Banco de Codigos
19/19
Application.E
al(Application.Version
Recommended