Desvio padrão em VBA

Escrito no Excel, mas facilmente adaptável aos outros aplicativos do Office.

;-)

Option Explicit
 
' variáveis para cálculo do desvio padrão
'========================================
Dim valores()      As Double
Dim desvio_padrao  As Double
Dim qtd_valores    As Integer
Dim soma           As Double
Dim soma_1         As Double
Dim i              As Integer
Dim media          As Double
'========================================

'Cálculo de desvio padrão
'Exemplo para valores na coluna A a partir de A1
'Os valores devem estar em células contíguas
'Resultado em B1
 
 
Sub calcular()
 
     qtd_valores = Range("A1").CurrentRegion.Rows.Count
     ReDim valores(qtd_valores)
 
     For i = 1 To qtd_valores
          valores(i) = Sheets("plan1").Cells(i, 1)
     Next i
    
     desvio_padrao = f_desvio_padrao(qtd_valores, valores)
     Sheets("plan1").Cells(1, 4) = "Desvio Padrão = " & desvio_padrao
 
End Sub
 
Function f_media(ByVal x As Long, valores() As Double)
    
     soma = 0
     For i = 1 To x
         soma = soma + valores(i)
     Next i
 
     f_media = soma / x
 
End Function
 
Function f_desvio_padrao(ByVal qtd_valores As Integer, valores() As Double)
 
     soma_1 = 0
     media = f_media(qtd_valores, valores)
     For i = 1 To qtd_valores
          soma_1 = soma_1 + (valores(i) - media) ^ 2
     Next i
 
     f_desvio_padrao = Sqr(soma_1 / (qtd_valores - 1))
 
End Function

Selecionar arquivo via caixa de diálogo - WORD VBA

É... de vez em quando eu faço alguma coisa no VBA do Word...

Dim fd          As FileDialog
dim arquivo  As String

Private Sub Abrir()
    
  Set fd = Application.FileDialog(msoFileDialogFilePicker)
  If fd.Show = -1 Then
      arquivo = fd.SelectedItems(1)
      MsgBox "O arquivo selecionado é " & arquivo
  Else
      arquivo = ""
      Exit Sub
  End If
  Set fd = Nothing

End Sub

;-)

Inserindo assinatura no Outlook - VBA

Ultimamente o Outlook tem sido o "alvo" das minhas necessidades de automatização...
Segue código para inserir assinatura numa mensagem criada via VBA.
Detalhe importante: o formato do e-mail deve ser HTML.

;-)

Option Explicit
Dim assinatura As Variant
 
Public Function pega_assinatura(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    pega_assinatura = ts.readall
    ts.Close
End Function
 
Sub Cria_mensagem_HTML()
'Creates a new e-mail item and modifies its properties.
 
    Dim olapp As Outlook.Application
    Dim objMail As MailItem
    Set olapp = Outlook.Application
    'Create mail item
    Set objMail = olapp.CreateItem(olMailItem)
   
    assinatura = pega_assinatura("C:\Documents and Settings\" & _
  Environ("username") & "\AppData\Roaming\Microsoft\Assinaturas\Paulo.htm")
 
    With objMail
       'Set body format to HTML
       'a tag 
 quebra linha
       'a tag  formata o texto para negrito
       .BodyFormat = olFormatHTML
       .HTMLBody = "Texto " & assinatura
       .Display
    End With
 
End Sub

Navegando num formulário contínuo do Access...

... com a mesma facilidade do Excel.
Este código é de autoria do Jaques Zetune da ForumAccess.
Estou deixando aqui mais para consultas, pois as vezes eu preciso e não tenho à mão.
Não esquecer de colocar um checkbox com o nome chkNavegLoop, valor padrão 1.


;-)

Option Explicit

Const cDataSheet = 2, cContinuous = 1

Private Sub Form_Load()
    Me.KeyPreview = True
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    DoKeys Me, KeyCode, Shift
End Sub

Public Sub DoKeys(wForm As Form, KeyCode As Integer, Shift As Integer)
    Dim wCtl As Control, wIgnore As Integer
    'a tecla Shift está pressionada ?
    If Shift <> 0 Then Exit Sub
    'o formulário está sendo visualizado em modo contínuo?
    If wForm.CurrentView <> cDataSheet And wForm.DefaultView <> cContinuous Then Exit Sub

On Error Resume Next

    Set wCtl = Screen.ActiveControl
    'testa o comportamento da tecla Enter no controle
    wIgnore = (wCtl.EnterKeyBehavior <> 0)
    'verifica se a barra de rolagem está ativada If Not wIgnore Then wIgnore = (wCtl.ScrollBars <> 0)
    'verifica se o controle em questão está com o texto “Ignore Setas” na propriedade Tag
    'indicando que a intercepção de teclas deve ser ignorada no mesmo
    If Not wIgnore Then wIgnore = (InStr(wCtl.Tag, "Ignore Setas") > 0)
    If wIgnore Then Exit Sub
    'sincroniza o registro corrente do formulário com o seu RecordsetClone
    Me.RecordsetClone.Bookmark = Me.Bookmark
    
    Select Case KeyCode
        Case vbKeyDown
            If Me.RecordsetClone.AbsolutePosition + 1 = Me.RecordsetClone.RecordCount And Me!chkNavegLoop Then
            'tentou ir além do topo e a navegação em loop está ativa
                DoCmd.GoToRecord , , acFirst
            Else
                DoCmd.GoToRecord , , acNext
            End If
            KeyCode = 0
        Case vbKeyUp
            If Me.RecordsetClone.AbsolutePosition = 0 And Me!chkNavegLoop Then
            'tentou ir além do final e a navegação em loop está ativa
                DoCmd.GoToRecord , , acLast
            Else
                DoCmd.GoToRecord , , acPrevious
            End If
            KeyCode = 0
    End Select
End Sub

Ajustar um UserForm para o tamanho da tela

E também não deixar o usuário clicar no "X" para fechar o UserForm.
Muito bom para quem gosta de mexer na interface do Excel via VBA, assim é possível voltar todas as configurações colocando o código no botão SAIR.

;-)

Private Sub CommandButton2_Click()
     Application.WindowState = xlMaximized
     Me.Height = Application.Height
     Me.Width = Application.Width
     Me.Left = Application.Left
     Me.Top = Application.Top
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Cancel = True
    MsgBox "clicar no botão sair!!!"
End Sub

Executar um processo quando o e-mail chegar

Esta é bem interessante: toda vez que chegar um e-mail com um determinado título, executar um processo.
Vamos usar como título, "executa_processo".
Assim, caso eu queira disparar um processo, basta que o meu computador esteja ligado e o Outlook aberto. Quando chegar uma mensagem com o título acima, o processo "minha_rotina" é executado.

;-)

Evento new_mail:
 
Private Sub Application_NewMail()   
   Call Procura   
End Sub
 
 
Sub Procura()
    'Procura mensagem na caixa de entrada
    'Critério: Assunto da mensagem
   
    Dim mySearch        As Search
    Dim myResults       As Results
    Dim intCounter      As Integer
    Dim strMessages     As String
 
    Set mySearch = AdvancedSearch(Scope:="Inbox", Filter:="urn:schemas:mailheader:subject = 'executa_processo'")
    Set myResults = mySearch.Results
    If myResults.Count > 0 Then
        Call minha_rotina
    Else
        Exit Sub
    End If
       
  
End Sub

Copiar informações de um e-mail no Outlook - VBA

Vou deixar registrado aqui vários trechos de códigos em VBA, para facilitar a consulta. Afinal, basta ter uma conexão com a internet, certo?
Segue abaixo, um exemplo para copiar dados de um e-mail selecionado no Outlook para qualquer outro aplicativo Office.
Detalhes:
- Referenciar o Outlook no projeto VBA;
- O e-mail precisa estar selecionado na caixa de entrada (para este exemplo).

;-)

 
Option Explicit
 
Dim oApp As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oWindow As Object
Dim omail As Outlook.MailItem
 
Private Sub Comando12_Click()
 
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oWindow = oApp.ActiveWindow
    Set omail = oApp.ActiveExplorer.Selection.Item(1)
   
    txt_remetente = omail.SenderName  'Remetente
    txt_cc = omail.CC         'Com cópia
    txt_assunto = omail.Subject    'Assunto
    txt_mensagem = omail.Body        'Mensagem
    txt_para = omail.To          'Destinatário
    txt_data = omail.ReceivedTime
   
End Sub

Achando o último dia do mês

Em algumas aplicações, principalmente as financeiras, às vezes é necessário obter o último dia de cada mês.

Seguem duas formas, uma com fórmula do Excel e outra em VBA.

Detalhe interessante: dia zero é o último dia do mês anterior.

;-)

Private Sub teste()
    Dim ultimo_dia_mes As Date
    ultimo_dia_mes = CDate(1 & "/" & Month(Now()) + 1 & "/" & Year(Now())) - 1
    If ultimo_dia_mes = Format(Now, "dd/mm/yyyy") Then
        MsgBox "ultimo dia"
    End If
End Sub

Acrescentando intervalos à data corrente

Uma dica simples para "fechar a loja" por hoje, afinal o dia começa cedo e agora (01:58 hrs) é bem cedo...
Supondo que numa célula, haja a fórmula com a data de hoje: =AGORA( ).
Se eu quiser saber a data daqui a 5 dias, basta fazer isto: = agora() + 5.
Para acrescentar 1 hora e 15 minutos: =agora() + tempo(1;15;0).

É isso aí.
Pelo menos não fecho o dia com um assunto "não Excel".

;-)))

Onde vamos parar ???

Não acredito no que acabo de ver.
Uma grande revista de informática escrevendo "tuíte" no seu site...
Daqui a pouco vai aparecer o "aipéd" e coisas do gênero!
Para mim só tem uma explicação: preguiça de escrever certo.

Arghhh....

p.s.: Apesar do assunto não ter nada a ver com o "Equicél" (perceberam como ficou ridículo?), fica a dica para não fazerem isso em seus textos no Office e espero que o Word continue indicando essas aberrações como palavras incorretas.

Video aulas no YouTube

Para quem gosta de vídeo-aulas, o YouTube está "recheado" de tutoriais de Excel e também de muitos outros softwares.

http://www.youtube.com/results?search_query=excel&aq=f

Sempre gostei de cursos multimídia, mas dando uma olhada nos tutoriais de Excel do YouTube, notei que a qualidade ainda deixa muito a desejar.

O vídeo é só razoável e o áudio muito pobre, provavelmente gravado com esses microfones caseiros (se não estiver enganado, são de eletreto).

Até hoje não vi nenhum curso multimídia que se comparasse em qualidade de aúdio e vídeo com os cursos da antiga Editora Terra, estes com vídeo muito bem trabalhado e áudio gravado em um estúdio de verdade.

Boa sorte para quem quiser tentar.

;-)

A pessoa que inventou deve ter achado o máximo!

Costumo dizer que a maioria dos inventores não usa o que inventa, pois certas "invenções" simplesmente não são funcionais, causam mais problemas do que ajudam ou é totalmente inútil.
Exemplo "simples" é a faixa de opções do Office 2007 que até hoje, não vi alguém que soubesse explicar qual é a lógica do agrupamento dos comandos.
Veio para atrapalhar a vida de quem já estava habituado com o funcional, intuitivo e tradicional menu.
Pior de tudo é que, outros desenvolvedores de software acharam linda a invenção e estão adotando o mesmo visual e agrupamento...
Vou deixar aqui a imagem de uma invenção que ilustra bem a situação. Pensaram na segurança para evitar spammer's e o recurso ficou tão seguro que nem o próprio dono da conta consegue mandar um simples e-mail!

Aliás, acho que nem mesmo o inventor dessa ... (deixa pra lá...) consegue acertar na primeira tentativa as letras.

;-)

Relógio numa célula

Bem simples:

;-)

Dim hora_atual As Date

Sub hora()

    ThisWorkbook.Sheets("Plan1").Range("A1").Value = Format(Time, "hh:mm:ss")
    Call acerta_hora

End Sub

Sub acerta_hora()

    hora_atual = Now + TimeValue("00:00:01")
    Application.OnTime hora_atual, "hora"
End Sub

Sub parar()
    Application.OnTime EarliestTime:=hora_atual, Procedure:="hora", Schedule:=False
End Sub

Listando emails do Outlook numa tabela do Access

Esta demanda partiu de um colega que precisou listar os emails pelos títulos em ordem cronológica.
Abaixo o código para consulta ou para quem precisar.
Rodamos no Office 2007.
Não esquecer de marcar a referência "Microsoft ActiveX Data Objects", qualquer versão.

;-)

Sub Listar_emails_Access()

   Dim rst                 As New ADODB.Recordset
   Dim cnn                 As New ADODB.Connection

   Dim contador_itens      As Integer
   Dim nms                 As Outlook.NameSpace
   Dim fld                 As Outlook.MAPIFolder
   Dim itm                 As Object

   Set nms = Application.GetNamespace("MAPI")
   Set fld = nms.PickFolder

   cnn.Open "Provider=Microsoft.JET.OLEDB.4.0;" & "Data Source=" & "C:\banco.mdb"

   rst.Open "Tabela1", cnn, adOpenKeyset, adLockOptimistic
   
   contador_itens = fld.Items.Count

   For Each itm In fld.Items
       If itm.Class = olMail Then
           rst.AddNew
           rst!titulo = itm.Subject
           rst!Data = itm.ReceivedTime
           rst.Update
       End If
   Next itm

   rst.Close
   cnn.Close

   MsgBox "Fim"

End Sub

Código para importação de arquivo texto delimitado

Vou deixar aqui só para eventual consulta.
O delimitador é o ponto-e-vírgula.
Arquivo texto sem cabeçalho.

;-)

Sub importa_delimitado()
   
    Dim entrada         As String       'linha do txt
    Dim i               As Single       'número de caracteres
    Dim linha           As Integer
    Dim coluna          As Integer
    Dim texto           As String       'texto a ser gravado na célula
    Dim ultimo          As Boolean      'controle do último caracter da linha
   
    Open "C:\Users\kazu\Desktop\pasta1.csv" For Input As #1
        
    linha = 1
    coluna = 1
    Do While Not EOF(1)
        Line Input #1, entrada
        For i = 1 To Len(entrada)
            If Mid(entrada, i, 1) = ";" Then
                Cells(linha, coluna).Value = texto
                coluna = coluna + 1
                texto = ""
            Else
                'Se for o último caracter, grava na célula
                If i = Len(entrada) Then
                    texto = texto & Mid(entrada, i, 1)
                    Cells(linha, coluna).Value = texto
                    coluna = coluna + 1
                    texto = ""
                    ultimo = True
                End If
                If Not ultimo Then texto = texto & Mid(entrada, i, 1)
            End If
            ultimo = False
        Next
        linha = linha + 1
        coluna = 1
    Loop
 
    Close #1
 
End Sub

Inserindo células copiadas em outro intervalo

Boas!

Para inserir um grupo de células em outro intervalo, muita gente costuma primeiro inserir novas células para depois colar o conteúdo copiado.
O meio mais fácil de fazer isso, é clicar com o botão direito, selecionar "Inserir células copiadas..." e depois optar por deslocar as células à direita ou abaixo.
No exemplo bem simples, eu inseri os números 4, 5 e 6 na primeira coluna em seus respectivos lugares.

;-)

Obtendo o reembolso pelo Windows OEM

Apenas vou deixar o link aqui.
Parabéns ao Otto Teixeira que conseguiu essa façanha e que muitos outros tenham sucesso contra a prepotência das empresas.

http://ottoteixeira.com/2010/03/21/como-conseguir-o-reembolso-pelo-windows-oem/

Espero que o link da Info não saia do ar tão rapidamente:
http://info.abril.com.br/noticias/tecnologia-pessoal/ele-rejeitou-o-windows-e-foi-reembolsado-24032010-34.shl


;-)

Transferindo contas do Outlook 2003 - parte 2

Pesquisando um pouco mais, encontrei um aplicativo interessante que resolveu o meu problema anterior.
Explicando, apesar de conseguir transferir a conta do Outlook 2003 para outro HD, ao baixar as mensagens do Yahoo!, estavam vindo todas e-mails desde a abertura da conta!
Ao executar o aplicativo Easy Transfer, o problema foi resolvido.
Abaixo o link para quem não quer ter dor de cabeça como eu tive...
http://www.microsoft.com/downloads/details.aspx?FamilyId=2B6F1631-973A-45C7-A4EC-4928FA173266&displaylang=en


;-)

Colar > Especial > Valores (texto em html)

Às vezes eu preciso copiar texto e/ou valores de sites que geralmente vêm no formato html para colar no Excel, para tanto eu uso Colar > Especial > Valores.
Um jeito mais prático, é colar diretamente na barra de fórmulas, que acaba tendo o mesmo efeito, porém com menos click's.
Experimentem!


;-)

Exportar conta de e-mail no Outlook 2003

Ao transferir meus arquivos para um novo HD, com o XP recém-instalado, deparei com um problema inesperado: exportar a conta de e-mail no Outlook origem para depois importá-la no novo WinXP.
Aparentemente uma tarefa simples, mas... não existe a opção de exportar a conta!
O Outlook Express que é a versão simplificada do leitor de e-mail tem esse recurso, não entendo porque a Microsoft não incluiu no "irmão mais velho".
Bem, pesquisando pela internet, encontrei a solução através de uma chave no registro.
Segue o caminho das pedras.
Depois de localizar a chave, basta exportá-la e importar no outro PC.
Artigo original em http://www.infonegocio.com/luzylar/cuentasoutlook2003.htm

A "maledeta":

HKEY_CURRENT_USER\
Software\
Microsoft\
Windows NT\
CurrentVersion\
Windows Messaging Subsystem\
\Profiles\
Outlook\
9375CFF0413111d3B88A00104B2A6676

;-)