MACROS PARA EXCEL 2

 

'.....................'

COMO USAR O CONTROLE SpinButton

Dim linha As Integer

Private Sub SpinButton1_SpinDown()

If linha = 1 Then Exit Sub

linha = linha - 1

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

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

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

UserForm1.TextBox4 = Sheets("Plan1").Cells(linha, 4)

End Sub

Private Sub SpinButton1_SpinUp()

linha = linha + 1

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

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

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

UserForm1.TextBox4 = Sheets("Plan1").Cells(linha, 4)

End Sub

Private Sub UserForm_Initialize()

linha = 2

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

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

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

UserForm1.TextBox4 = Sheets("Plan1").Cells(linha, 4)

End Sub

'...................

 

 CONTA VALORES EM DETERMINADO RANGE

 

Sub Cont_Valores()

Dim Cont As Integer

Dim i As Integer

 

Cont = 0

range("a5").Select

 

For i = 5 To 30 Step 1

    Cells(i, 1).Select

        If IsEmpty(ActiveCell) = False Then

            Cont = Cont + 1

        End If

Next

        range("b2").Value = Cont + 4

End Sub

'......................'

 

SOBRE O CONTROLE LISTBOX

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

On Error Resume Next

TextBox1.Text = ListBox1.Text

TextBox2.Text = ListBox1.Column(1, Me.ListBox1.ListIndex)

TextBox3.Text = ListBox1.Column(2, Me.ListBox1.ListIndex)

TextBox4.Text = ListBox1.Column(3, Me.ListBox1.ListIndex)

TextBox5.Text = ListBox1.Column(4, Me.ListBox1.ListIndex)

TextBox6.Text = ListBox1.Column(5, Me.ListBox1.ListIndex)

End Sub

 

Private Sub UserForm_Initialize()

ListBox1.ColumnWidths = "1 cm; 2 cm; 1,5 cm; 4 cm; 6 cm; 2 cm "

End Sub

'......................'

COMO COPIAR E COLAR COM UMA MACRO

Sub nome_da_macro()

Range("A1:A10").Copy

Range("B2").Select

ActiveSheet.Paste

End Sub

'......................'

COMO POSSO CRIAR MAIS DE UMA PASTA NO DIRETORIO

Sub nome_da_macro()

Dim fso, f,f1,f2,f3

   Set fso = CreateObject("Scripting.FileSystemObject")

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

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

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

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

   CreateFolderDemo = f.Path

   CreateFolderDemo = f1.Path

   CreateFolderDemo = f2.Path

   CreateFolderDemo = f3.Path

End Sub

'.........................'

Sub nome_da_macro()

Set fs = CreateObject("Scripting.FileSystemObject")

    Set a = fs.CreateTextFile("c:\Nome do arquivo.txt", True)

    a.WriteLine("Texto dentro do arquivo.")

    a.Close

End Sub

'.........................'

 

 

CRIAR UM CAMPO DE PESQUISA EM UM FORMULARIO.

Dim Search As String

Dim Searchlen As String

Search$ = UCase$(txt_pesquisa.Text)

   Searchlen = Len(Search$)

   If Searchlen Then

     For i = 0 To List1.ListCount - 1

       If UCase$(Left$(List1.List(i), Searchlen)) = Search$ Then

         List1.ListIndex = i

         Exit For

       End If

     Next

   End If

'.........................'

COMO CRIAR UM EVENTO PARA DETERMINAR TEMPO

Public Sub Espere(ByVal QtdSegundos As Long)

Static Início As Variant

   If Início = 0 Then Início = Time

 

   While DateDiff("s", Início, Time) < QtdSegundos

 

       DoEvents   ' faça outras coisas enquanto espera

      ' se cruzar a meia-noite, volte um dia (86400 segundos)

      If DateDiff("s", Início, Time) < 0 Then

        Início = DateAdd("s", -86400, Início)

      End If

   Wend

   Início = 0

 End Sub

'.......................'

 

CRIAR UM ITEM NA BARRA DE MENUS

Option Explicit

Private Sub add_menu()

    Dim NewItem As Object, NewToolsItem As Object

 

        Set NewToolsItem = MenuBars(xlWorksheet).Menus.Add(Caption:="Bethoven")

        Set NewItem = MenuBars(xlWorksheet) _

        .Menus("Bethoven").MenuItems.Add(Caption:="Creditos", OnAction:="CreditsSub")

End Sub

'......'

Sub CreditsSub()

MsgBox "legalll"

End Sub

'......'

Sub deletar_menu()

    On Error GoTo erro

MenuBars(xlWorksheet).Menus("Bethoven").Delete

Exit Sub

erro:

MsgBox "O Item já foi deletado!", vbInformation, "Aviso!!"

End Sub

'......'

Sub Chamar_menu()

 Call add_menu

End Sub

'......................'

 

 

MACRO PARA CRIAR UMA PASTA EM DETERMINADO DIRETORIO

Sub nome_da_macro()

Dim fso, f

   Set fso = CreateObject("Scripting.FileSystemObject")

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

   CreateFolderDemo = f.Path

End Sub

'.....................'

DESBLOQUEAR VBA

Sub DesbloquearVBProject()

   If Val(Application.Version) > 8 Then

      SendKeys _

         "%{F11}%fp^{TAB}%b{TAB}" & _

         "{DEL}" & "{TAB}" & "{DEL}" & "{TAB}{ENTER}%af"

   End If

 

End Sub

'....................'

DESLOCANDO A SELEÇAO PARA OUTRA PLANILHA

Sub nome_da_macro()

Sheets("Plan1").Select

Range("A1").Select

End Sub

'....................'

DESPROTEGER UMA PLANILHA COM SENHA:

Sub nome_da_macro ()

 

   Dim i As Integer, j As Integer, k As Integer

   Dim 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 "A  Senha foi quebrada com sucesso”

      Exit Sub

   End If

               Next

              Next

             Next

            Next

           Next

          Next

         Next

        Next

       Next

      Next

     Next

    Next

 

End Sub

'......................

DESPROTEGENDO UMA PLANILHA ATRAVES DO VBA.'

 

Sub nome_da_macro()

ActiveSheet.Unprotect password:="senha"

End Sub

'.....

 

................'

MACRO ENVIA EMAIL, VIA VBA

Sub Enviar()

Dim Outlook As Object

Dim Email As Object

Dim Pasta As Workbook

Dim userInput As String

 

Msg = "Seguem os Relatórios, Tenha um bom dia!..."

 

Set Outlook = CreateObject("Outlook.Application")

Set Email = Outlook.CreateItem(olMailItem)

 

With Email

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

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

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

   .Attachments.Add "C:\Documents and Settings\TR003851\Desktop\04.htm"

   .To = "contato@saberexcel.com"

   .CC = "excelvbaestudos@hotmail.com"

   .BCC = ""

   .Subject = ActiveWorkbook.Name

   .Body = Msg

   .send

 

End With

 

Set Email = Nothing 'Limpa a memória

Set Outlook = Nothing 'Limpa a memória

End Sub

 

'.....................'

 

SENHA & ERRO FATAL

Sub Erro_Fatal()

    senha = "Saber"

    If Application.InputBox("Digite a senha autorizada", "Saberexcel", "Saber") = senha Then

    Else

    MsgBox "VOCÊ NÃO E AUTORIZADO", vbCritical, "Saberexcel

    FatalExit 1

    End If

End Sub

 

 

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

Private Declare Sub FatalExit Lib "kernel32" (ByVal code As Long)

 

Sub Erro_Fatal_Personal()

    senha = "Saber"

    If Application.InputBox("Digite a senha autorizada", "saberexcel.com", "Saber") = senha Then

    Else

    FatalAppExit 0, "ACESSO NÃO PERMITIDO, DESCULPE!"

    End If

End Sub

'.....................'