About Me

A minha foto
JRod - PORTUGAL
Microsoft [MVP] - Excel (10º ano consecutivo)
Ver o meu perfil completo
Com tecnologia do Blogger.

Seguidores

Estatisticas

Free Blog Counter

eXTReMe Tracker
2007-04-06

Se pretendermos efectuar uma ordenação por escolha através de uma InputBox, como no exemplo:

 

para o resultado:

 

ou:

 

para o resultado:

 

podemos utilizar o seguinte código:

 

Sub Ordena()
'
' Macro recorded 04-04-2007 by JRod
'

'

    Dim Choice As String
    Choice = InputBox("Ordenar por:")
    If Choice = "data" Then
        Range("A2:B6").Select
        Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                       DataOption1:=xlSortNormal
    ElseIf Choice = "nome" Then
        Range("A2:B6").Select
        Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
                       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                       DataOption1:=xlSortNormal
    Else
        Exit Sub
    End If
End Sub
2007-03-28

Uma pequena adaptação ao post anterior para mostrar como é que se pode apresentar, no comentário, quantos dias já passaram sobre determinada data (cfr. exemplo):

 

 

O Código, adaptado:

 

Private Sub Workbook_Open()
    Dim r As Long
    Dim temp, temp1 As String

    temp = "Atenção!!! Já passaram "

    temp1 = " dias sobre o início da baixa!"


    For r = Range("C1:C10").Count To 1 Step -1
        Range("C" & r).ClearComments

        If Range("C" & r) > 26 Then
            Range("C" & r).Interior.ColorIndex = 5
            Range("C" & r).AddComment
            Range("C" & r).Comment.Text Text:=temp & Range("C" & r) & temp1
            Range("C" & r).Comment.Visible = True
        Else
            Range("C" & r).Interior.ColorIndex = xlNone
            Range("C" & r).ClearComments
        End If
    Next r

End Sub
2007-03-20

Se pretendermos, ao abrir um workbook, que a célula (resultado da diferença entre duas datas) que contenha um resultado igual ou superior a x dias (no exemplo, 27) apresente uma coloração ( no exemplo, azul) e um comentário, que desaparecerão (coloração e comentário) se a diferença for inferior,  como no exemplo:

 

 

podemos utilizar o seguinte Código:
 
Private Sub Workbook_Open()
    Dim r As Long
    Dim temp As String

    temp = "Atenção!!! Já passaram mais do que 27 dias sobre o início da baixa!"


    For r = Range("C1:C10").Count To 1 Step -1
        Range("C" & r).ClearComments

        If Range("C" & r) > 26 Then
            Range("C" & r).Interior.ColorIndex = 5
            Range("C" & r).AddComment
            Range("C" & r).Comment.Text Text:=temp
            Range("C" & r).Comment.Visible = True
        Else
            Range("C" & r).Interior.ColorIndex = xlNone
            Range("C" & r).ClearComments
        End If
    Next r

End Sub

 

NOTA: O Código deve ser inserido no próprio workbook:

 

2007-03-17
 
Num newsgroup de Excel, perguntou-se como se poderia criar uma mensagem no Outlook, para avisar determinada pessoa, que já passaram mais do que três dias sobre a data limite e que, por, isso, essa pessoa deveria contactar os serviços, com urgência.
 
Supondo que, em A1, temos a data inicial, ou seja, a data limite (no exemplo: 07-03-2007) e que, em B1, temos a data actual, representada pela fórmula =TODAY()
 
Então, em C1, teremos o resultado da diferença entre B1 e A1, ou seja, a fórmula =B1-A1
 
E, para identificarmos a pessoa que está em falta, através do seu endereço de e-mail, no caso de já estar fora dos parâmetros introduzidos, colocamos, em F1, a seguinte fórmula:
 
=IF(C1>3;"jordao@junior.com";"")
 
Vejamos a imagem do exemplo:
 
Criamos agora um botão de comando, que há-de conter o seguinte código:
 

Private Sub CommandButton1_Click()
    Dim oOutlook As Object
    Dim oMailItem As Object
    Dim oRecipient As Object
    Dim oNameSpace As Object

    Set oOutlook = CreateObject("Outlook.Application")
    Set oNameSpace = oOutlook.GetNameSpace("MAPI")
    oNameSpace.Logon , , True


    Set oMailItem = oOutlook.CreateItem(0)
    Set oRecipient = _
    oMailItem.Recipients.Add(Range("F1").Value)
    oRecipient.Type = 1


    With oMailItem
        .Subject = "ATENÇÃO!"
        .Body = "Já passaram mais de 3 dias! Contacte o Serviço com urgência!"
        .Display
    End With

End Sub

 

O resultado será este:

 

2007-03-09
Se pretendermos obter numa célula, apenas com um duplo click, o valor total resultante da soma de um Range variável, na mesma coluna, Range esse que se inicie na 2ª linha e termine na linha imediatamente anterior à célula onde queremos o total, como no exemplo:
 
 
podemos utilizar o seguinte Código:
 

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim name As String
    Dim name1 As String
    Dim name2 As String
    Dim Start As Long
    
    Cancel = True
    
    name = ActiveCell.Address
    name1 = Left(name, 2)
    name2 = ActiveCell.End(xlUp).Address
    Start = 2
    Range(name).Formula = _
    "=SUM(" & name1 & Start & ":" & name2 & ")"
End Sub

 

Nota: A variável Start tem o valor 2, para que o Range se inicie na 2ª linha e não na primeira, em virtude de haver cabeçalho na coluna. Para que a célula não fique activa ao dar-se o duplo click, deu-se a condição True à Propriedade Cancel.

2007-03-03

Se num determinado Range pretendermos encontrar a primeira célula vazia, entre várias células preenchidas e vazias, como no exemplo,

podemos utilizar um pouco de código VBE, de modo a, por um lado, termos uma mensagem a dizer-nos qual é a célula e, de seguida, posicionarmo-nos nessa mesma célula.

 

O Código:

Option Explicit


Sub FindFirstEmptyCell()

    Dim myRange As Range

    On Error Resume Next
    Set myRange = Range("A:B").SpecialCells(xlCellTypeBlanks)(1)
    On Error GoTo 0


    If myRange Is Nothing Then
        MsgBox "Não existem células vazias no Range!"
    Else
        MsgBox myRange.Address
    End If

    Range(myRange.Address).Select

End Sub
2007-02-10

Se pretendermos copiar dados de uma folha para outra, de modo sequencial e partindo do princípio de que esses dados não se encontram sempre, na sua origem, nas mesmas células, mas mantendo-se na mesma ordem por coluna, como no exemplo:
 
Folha1 (1º momento):
 
 
Folha2 (1º momento):
 
 
Folha1 (2º momento):
 
Folha2 (2º momento):
 
 
Podemos então, para conseguir este resultado:
 
 1º - Definir o Range e atribuir-lhe um nome (no exemplo: "Vendas"):
 
 
2º - Executar o seguinte Código num módulo VBE:
 
 Sub TransferCells()

    Const SOURCESHEETNAME As String = "Sheet1"
    Const DESTSHEETNAME As String = "Sheet2"
    Dim copyRange As Range
    Dim cell As Range
    Dim destinationRange As Range

    Worksheets(SOURCESHEETNAME).Select

    Set destinationRange = Worksheets(DESTSHEETNAME).Range("A1")

    For Each cell In Range("Vendas").Resize(, 1)
        If cell.Value = "Vendas" Then
            If copyRange Is Nothing Then
                Range(cell, cell.Offset(0, 1)).Copy Destination:= _
                                                    Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        End If
    Next cell

End Sub
2007-01-31

Se pretendermos construir um ToolBar personalizado (a que chamaremos "MyToolBar"), desactivando outros ToolBars existentes, deixando apenas activo o ToolBar denominado "WorkSheet Menu Bar" e o MyToolBar e ainda que este seja apagado quando saímos do workbook, reactivando todos os outros ToolBars e, por fim, que, quando de novo abrirmos o workbook, voltemos a ter o MyToolBar  disponível, podemos utilizar as seguintes peças de código, para o exemplo que se apresenta:

 

 

 

Código num módulo:

Sub MakeToolBar()
 
    On Error Resume Next
    Application.CommandBars("MyToolBar").Delete
    On Error GoTo 0


    With Application.CommandBars.Add(Name:="MyToolBar", _
                                     Position:=msoBarTop, MenuBar:=False)

        .Protection = msoBarNoCustomize


        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .DescriptionText = "Imprime, Grava e Sai"
            .TooltipText = "Imprime, Grava e Sai"
            .Caption = "Imprime/Grava/Sai"
            .OnAction = "Imprime_Grava" 
        End With

        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .DescriptionText = "Limpar os Dados Anteriores"
            .TooltipText = "Limpa os Dados Anteriores"
            .Caption = "Limpa Dados"
            .OnAction = "Limpa"
        End With

        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .DescriptionText = "Gravar o Novo Mês"
            .TooltipText = "Grava o Novo Mês"
            .Caption = "Novo Mês"
            .OnAction = "GravaSai"
        End With

        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .DescriptionText = "Inserção do valor que vem do fecho do mês anterior"
            .TooltipText = "Digitar o Valor do Mês Anterior"
            .Caption = "Valor Mês Anterior"
            .OnAction = "Valor_Anterior"
        End With

        Application.CommandBars("MyToolBar").Visible = True

    End With
End Sub

Sub DeleteToolBar()
    Dim bar As CommandBar
    On Error Resume Next
    Application.CommandBars("MyToolBar").Delete
    On Error GoTo 0
End Sub

 

Código no Workbook:

Private Sub Workbook_Activate()


    On Error Resume Next


    With Application.CommandBars("Worksheet Menu Bar")
        .Enabled = True
        .Visible = True
    End With

    With Application.CommandBars("Formatting")
        .Enabled = False
        .Visible = False
    End With


    With Application.CommandBars("Standard")
        .Enabled = False
        .Visible = False
    End With


    With Application.CommandBars("TranslateIT")
        .Enabled = False
        .Visible = False
    End With

    MakeToolBar

    On Error GoTo 0
End Sub


Private Sub Workbook_Deactivate()


    On Error Resume Next


    With Application.CommandBars("Worksheet Menu Bar")
        .Enabled = True
        .Visible = True
    End With

    With Application.CommandBars("Formatting")
        .Enabled = True
        .Visible = True
    End With


    With Application.CommandBars("Standard")
        .Enabled = True
        .Visible = True
    End With


    With Application.CommandBars("TranslateIT")
        .Enabled = True
        .Visible = True
    End With

    DeleteToolBar

    On Error GoTo 0
End Sub

2007-01-12

Se pretendermos  usar o Excel para listar o conteúdo de um directório ou de uma pasta, mostrando cada nome de ficheiro numa célula de uma coluna (no exemplo, coluna A) e mostrando, igualmente a data/hora na célula correspondente da coluna seguinte e ainda fazer com que as colunas fiquem com a sua largura ajustada ao tamanho do  nome do ficheiro mais extenso, como no exemplo:

   

 

podemos utilizar o seguinte código:

 

' A partir do código apresentado num newsgroup por Tom Ogilvy

Sub ListDirectory()
Dim Msg As String
Dim rw As Long
Dim i As Long
Dim sDir As String
Msg = InputBox("Escolha o Path:")
sDir = Msg


If Len(Trim(Msg)) = 0 Then
  MsgBox "Não seleccionou nada . . ."
  Exit Sub
End If


With Application.FileSearch
    .NewSearch
    .LookIn = sDir
    .SearchSubFolders = True
    .FileName = "*.*"
    .FileType = msoFileTypeAllFiles
    rw = 2
    If .Execute() > 0 Then
    Sheets("Sheet1").Range("A:A").Clear

        For i = 1 To .FoundFiles.Count
            Sheets("Sheet1").Cells(rw, "A").Value = Dir(.FoundFiles(i))
            Sheets("Sheet1").Cells(rw, "B").Value = FileDateTime(.FoundFiles(i))
            rw = rw + 1
        Next i
    Else
        MsgBox "Não foram encontrados ficheiros"
    End If
End With
Sheets("Sheet1").Cells(1, 1).Value = "Nome do Ficheiro"
Sheets("Sheet1").Cells(1, 2).Value = "Data/Hora"
Columns("A:B").AutoFit
End Sub

2007-01-08

Se pretendermos transformar Nome e Apelido em Apelido, Nome como no exemplo:

podemos utilizar a seguinte fórmula (créditos para Bob Phillips):

=MID(A1;FIND(" "A1)+1;255)&", "&LEFT(A1;FIND(" "A1))

 

Mas se pretendermos o contrário, ou seja, transformar Apelido, Nome em Nome e Apelido como no exemplo:

então, poderemos utilizar, a partir da fórmula anterior, a seguinte fórmula alterada:

=MID(A2;FIND(" ";A2)+1;255)&" "&LEFT(A2;FIND(", ";A2)-1)