About Me
Seguidores
Estatisticas
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
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
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:
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:
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.
O Código:
Option ExplicitSub 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
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
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
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
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)