About Me
Estatisticas
2006-05-01
9:25 p.m. | 
Publicada por
JRod - PORTUGAL
Se pretendermos contar quantas células existem num determinado Range e que contenham valores apresentadas numa determinada cor, ou se quisermos somar os valores com a mesma cor contidos nesse mesmo Range, como no exemplo seguinte:
,
podemos criar duas User Defined Functions (UDF). Por outro lado, para sabermos a que número corresponde cada uma das 56 cores da palette de cores do Excel, podemos utilizar uma macro, que, ao que julgo, é da autoria do MVP Excel - Tom Ogilvy.
Os Códigos:
(Para contar as ocorrências):
Option Explicit
Function CountFc(rng As Range, Num As Long)
Dim Item
Application.Volatile
For Each Item In rng
If Item.Font.ColorIndex = Num Then CountFc = CountFc + 1
Next
End Function
(Para somar as ocorrências):
Option Explicit
Function SumFC(Source As Range, Num As Long)
Application.Volatile
Dim total As Double
Dim cell As Range
For Each cell In Source
With cell
If .Font.ColorIndex = Num Then
total = total + .Value
End If
End With
Next
SumFC = total
End Function
(Para mostrar a palette de cores):
' By Tom Ogilvy
Sub ShowPalette()
varr = SetPaletteArray
Set rng = Cells(1, 1).Resize(7, 8)
rng.Value = varr
rng.HorizontalAlignment = xlCenter
For Each cell In rng
cell.Interior.ColorIndex = cell.Value
Next
Range("A:H").ColumnWidth = 3.29
Range("A1:H2,A7,H7,E6,E7,F7").Font.ColorIndex = 2
End Sub
Public Function SetPaletteArray()
varr1 = Evaluate(" { 1,53,52,51,49,11,55,56; " & _
"9,46,12,10,14,5,47,16;" & _
"3,45,43,50,42,41,13,48;" & _
"7,44,6,4,8,33,54,15;" & _
"38,40,36,35,34,37,39,2;" & _
"17,18,19,20,21,22,23,24;" & _
"25,26,27,28,29,30,31,32}")
SetPaletteArray = varr1
End Function
Nota:
Como muito bem refere o MVP Excel - Kiril Lapin (KL), num newsgroup, a este propósito:
" 1) O problema principal, consiste em que o Excel não tem nenhum evento que seja impelido quando muda o formato da célula e, consequentemente, não há maneira de advertir uma fórmula, função, macro, etc., atempadamente, de que a mudança ocorreu.
2) Como se disse, não podemos detectar o momento da mudança do formato, pelo que só nos resta ir checando periodicamente (quanto mais frequentemente melhor). Isto poderá ser conseguido, entre outras coisas, mediante a volatilidade da fórmula."
,podemos criar duas User Defined Functions (UDF). Por outro lado, para sabermos a que número corresponde cada uma das 56 cores da palette de cores do Excel, podemos utilizar uma macro, que, ao que julgo, é da autoria do MVP Excel - Tom Ogilvy.
Os Códigos:
(Para contar as ocorrências):
Option Explicit
Function CountFc(rng As Range, Num As Long)
Dim Item
Application.Volatile
For Each Item In rng
If Item.Font.ColorIndex = Num Then CountFc = CountFc + 1
Next
End Function
(Para somar as ocorrências):
Option Explicit
Function SumFC(Source As Range, Num As Long)
Application.Volatile
Dim total As Double
Dim cell As Range
For Each cell In Source
With cell
If .Font.ColorIndex = Num Then
total = total + .Value
End If
End With
Next
SumFC = total
End Function
(Para mostrar a palette de cores):
' By Tom Ogilvy
Sub ShowPalette()
varr = SetPaletteArray
Set rng = Cells(1, 1).Resize(7, 8)
rng.Value = varr
rng.HorizontalAlignment = xlCenter
For Each cell In rng
cell.Interior.ColorIndex = cell.Value
Next
Range("A:H").ColumnWidth = 3.29
Range("A1:H2,A7,H7,E6,E7,F7").Font.ColorIndex = 2
End Sub
Public Function SetPaletteArray()
varr1 = Evaluate(" { 1,53,52,51,49,11,55,56; " & _
"9,46,12,10,14,5,47,16;" & _
"3,45,43,50,42,41,13,48;" & _
"7,44,6,4,8,33,54,15;" & _
"38,40,36,35,34,37,39,2;" & _
"17,18,19,20,21,22,23,24;" & _
"25,26,27,28,29,30,31,32}")
SetPaletteArray = varr1
End Function
Nota:
Como muito bem refere o MVP Excel - Kiril Lapin (KL), num newsgroup, a este propósito:
" 1) O problema principal, consiste em que o Excel não tem nenhum evento que seja impelido quando muda o formato da célula e, consequentemente, não há maneira de advertir uma fórmula, função, macro, etc., atempadamente, de que a mudança ocorreu.
2) Como se disse, não podemos detectar o momento da mudança do formato, pelo que só nos resta ir checando periodicamente (quanto mais frequentemente melhor). Isto poderá ser conseguido, entre outras coisas, mediante a volatilidade da fórmula."
2006-04-27
Se pretendermos efectuar um filtro, utilizando dados provenientes de determinadas células, como no exemplo:
podemos utilizar um pouco de Código VBA:
'---------------------------------------------------------------
' Procedure : Filtra_Click
' DateTime : 24-04-2006 19:07
' Author : JRod
' Purpose : Efectua um filtro por data anterior ou posterior
' : (célula I3) à data inscrita na célula I5
' : Se I5 for vazio, desfaz o filtro
'---------------------------------------------------------------
'
Private Sub Filtra_Click()
Dim myStartDate
Range("F6:F700").Select
myStartDate = Worksheets(1).Cells(5, 9).Value
If myStartDate = "" Then
Selection.AutoFilter
Range("K1").Select
Else
Selection.AutoFilter Field:=1, Criteria1:=Worksheets(1).Cells(3, 9).Value & _
CLng(Worksheets(1).Cells(5, 9).Value), Operator:=xlAnd
Range("K1").Select
End If
End Sub
podemos utilizar um pouco de Código VBA:
'---------------------------------------------------------------
' Procedure : Filtra_Click
' DateTime : 24-04-2006 19:07
' Author : JRod
' Purpose : Efectua um filtro por data anterior ou posterior
' : (célula I3) à data inscrita na célula I5
' : Se I5 for vazio, desfaz o filtro
'---------------------------------------------------------------
'
Private Sub Filtra_Click()
Dim myStartDate
Range("F6:F700").Select
myStartDate = Worksheets(1).Cells(5, 9).Value
If myStartDate = "" Then
Selection.AutoFilter
Range("K1").Select
Else
Selection.AutoFilter Field:=1, Criteria1:=Worksheets(1).Cells(3, 9).Value & _
CLng(Worksheets(1).Cells(5, 9).Value), Operator:=xlAnd
Range("K1").Select
End If
End Sub
O denominado Microsoft Mobile & Embedded Devcon 2006 Europe (MEDC), vai ter lugar em Nice, de 6 a 8 de Junho próximos.
Para melhor informação, pode aceder-se às páginas:
Microsoft Mobile & Embedded Devcon 2006 Europe;
MEDC I;
MEDC II;
MS-Mobiles.com
Também se pode ver mais qualquer coisa em Paul Mooney.
Se estiverem interessados, será uma boa ocasião para troca de ideias e ouvir os experts na matéria.
Para melhor informação, pode aceder-se às páginas:
Microsoft Mobile & Embedded Devcon 2006 Europe;
MEDC I;
MEDC II;
MS-Mobiles.com
Também se pode ver mais qualquer coisa em Paul Mooney.
Se estiverem interessados, será uma boa ocasião para troca de ideias e ouvir os experts na matéria.
2006-04-10
Se quisermos saber o nome do utilizador e a data e hora do acesso a determinado workbook, como no exemplo:
Obteremos o seguinte resultado:
O Código do exemplo:
Sub Auto_Open()
Dim Ops(1 To 5) As String
Dim Msg As String
Ops(1) = Day(Date)
Ops(2) = Month(Date)
Ops(3) = Year(Date)
Ops(4) = Hour(Time)
Ops(5) = Minute(Time)
Msg = Ops(3) & "-" & Ops(2) & "-" & Ops(1) & " " & Ops(4) & ":" & Ops(5)
Sheets("Sheet1").Select
Range("A65536").Select
Selection.End(xlUp).Select ' Selecciona a última célula não vazia do Range
ActiveCell.Offset(1, 0).Select ' Selecciona a primeira célula vazia do Range
Application.Cursor = xlNormal
Do While IsEmpty(ActiveCell)
ActiveCell.Value = InputBox(Prompt:="Introduza o seu NOME:", _
Title:="Nome do Utilizador")
ActiveCell.Value = UCase(ActiveCell) ' Transforma em letras maiúsculas
Loop
Range("B65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Msg
End
End Sub
Obteremos o seguinte resultado:
O Código do exemplo:
Sub Auto_Open()
Dim Ops(1 To 5) As String
Dim Msg As String
Ops(1) = Day(Date)
Ops(2) = Month(Date)
Ops(3) = Year(Date)
Ops(4) = Hour(Time)
Ops(5) = Minute(Time)
Msg = Ops(3) & "-" & Ops(2) & "-" & Ops(1) & " " & Ops(4) & ":" & Ops(5)
Sheets("Sheet1").Select
Range("A65536").Select
Selection.End(xlUp).Select ' Selecciona a última célula não vazia do Range
ActiveCell.Offset(1, 0).Select ' Selecciona a primeira célula vazia do Range
Application.Cursor = xlNormal
Do While IsEmpty(ActiveCell)
ActiveCell.Value = InputBox(Prompt:="Introduza o seu NOME:", _
Title:="Nome do Utilizador")
ActiveCell.Value = UCase(ActiveCell) ' Transforma em letras maiúsculas
Loop
Range("B65536").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Msg
End
End Sub
2006-04-06
Um dia destes, foi-me perguntado, por mail, qual a fórmula que permite contar as ocorrências de um caracter numa célula. Exemplo:
Quantos caracteres "." tem na célula A1 cujo conteúdo é 01.02.03.04? A célula A1 neste caso é do tipo texto. O resultado deveria ser 3.
Utilizando as Funções LEN() e SUBSTITUTE(), obtém-se o resultado desejado:
A fórmula em B1:
=LEN(A1)-LEN(SUBSTITUTE(A1;".";""))
(em Português):
=NÚM.CARACT(A1)-NÚM.CARACT(SUBSTITUIR(A1;".";""))
Quantos caracteres "." tem na célula A1 cujo conteúdo é 01.02.03.04? A célula A1 neste caso é do tipo texto. O resultado deveria ser 3.
Utilizando as Funções LEN() e SUBSTITUTE(), obtém-se o resultado desejado:
A fórmula em B1:
=LEN(A1)-LEN(SUBSTITUTE(A1;".";""))
(em Português):
=NÚM.CARACT(A1)-NÚM.CARACT(SUBSTITUIR(A1;".";""))
2006-03-19
Se pretendermos que uma determinada célula sequencie sempre que quisermos abrir um workbook, podemos utilizar o seguinte código de McGimpsey, com a adaptação no código de abertura do workbook, uma vez que se incluiu no número sequencial o ano, no formato "nn/aa", com a porção de código & "/" & Right(Date, 2)
O código da Função NextSeqNumber():
Public Function NextSeqNumber(Optional sFileName As String, Optional nSeqNumber As Long = -1) As Long
Const sDEFAULT_PATH As String = "C:\GABINETE"
Const sDEFAULT_FNAME As String = "defaultseq.txt"
Dim nFileNumber As Long
nFileNumber = FreeFile
If sFileName = "" Then sFileName = sDEFAULT_FNAME
If InStr(sFileName, Application.PathSeparator) = 0 Then _
sFileName = sDEFAULT_PATH & Application.PathSeparator & sFileName
If nSeqNumber = -1& Then
If Dir(sFileName) <> "" Then
Open sFileName For Input As nFileNumber
Input #nFileNumber, nSeqNumber
nSeqNumber = nSeqNumber + 1&
Close nFileNumber
Else
nSeqNumber = 1&
End If
End If
On Error GoTo PathError
Open sFileName For Output As nFileNumber
On Error GoTo 0
Print #nFileNumber, nSeqNumber
Close nFileNumber
NextSeqNumber = nSeqNumber
Exit Function
PathError:
NextSeqNumber = -1&
End Function
NOTA:
sDEFAULT_PATH e sDEFAULT_FNAME indicados a título de exemplo, podendo ser, como óbvio, alterados.
NOTA:
A célula onde recai o valor sequencial, deve ser formatada como texto.
O Código de abertura do Workbook:
Private Sub Workbook_Open()
ThisWorkbook.Sheets(1).Range("B2").Value = NextSeqNumber & "/" & Right(Date, 2)
End Sub
O resultado:
O código da Função NextSeqNumber():
Public Function NextSeqNumber(Optional sFileName As String, Optional nSeqNumber As Long = -1) As Long
Const sDEFAULT_PATH As String = "C:\GABINETE"
Const sDEFAULT_FNAME As String = "defaultseq.txt"
Dim nFileNumber As Long
nFileNumber = FreeFile
If sFileName = "" Then sFileName = sDEFAULT_FNAME
If InStr(sFileName, Application.PathSeparator) = 0 Then _
sFileName = sDEFAULT_PATH & Application.PathSeparator & sFileName
If nSeqNumber = -1& Then
If Dir(sFileName) <> "" Then
Open sFileName For Input As nFileNumber
Input #nFileNumber, nSeqNumber
nSeqNumber = nSeqNumber + 1&
Close nFileNumber
Else
nSeqNumber = 1&
End If
End If
On Error GoTo PathError
Open sFileName For Output As nFileNumber
On Error GoTo 0
Print #nFileNumber, nSeqNumber
Close nFileNumber
NextSeqNumber = nSeqNumber
Exit Function
PathError:
NextSeqNumber = -1&
End Function
NOTA:
sDEFAULT_PATH e sDEFAULT_FNAME indicados a título de exemplo, podendo ser, como óbvio, alterados.
NOTA:
A célula onde recai o valor sequencial, deve ser formatada como texto.
O Código de abertura do Workbook:
Private Sub Workbook_Open()
ThisWorkbook.Sheets(1).Range("B2").Value = NextSeqNumber & "/" & Right(Date, 2)
End Sub
O resultado:
2006-03-04
Por vezes, podemos ter a necessidade e utilizar, num Userform, um TextBox com comprimento fixo e com Multiline e WordWrap. Vejamos o exemplo:
Quando se inicia a escrita, a altura do TextBox aumenta automaticamente até à altura previamente definida:
Grava para a célula A1:
Para invocar o Userform que contem o TextBox, criamos um CommandButton na grelha:
O Código para o Comando:
Private Sub CommandButton1_Click()
FrmTeste.Show
End Sub
Os códigos em VBA:
Private Sub TextBox1_Change()
TextBox1.Width = 150
TextBox1.MultiLine = True
TextBox1.WordWrap = True
TextBox1.AutoSize = False
With Me.TextBox1
.Height = 80
End With
End Sub
Private Sub CommandButton1_Click()
Range("A1") = TextBox1.Value
End Sub
Quando se inicia a escrita, a altura do TextBox aumenta automaticamente até à altura previamente definida:
Grava para a célula A1:
Para invocar o Userform que contem o TextBox, criamos um CommandButton na grelha:
O Código para o Comando:
Private Sub CommandButton1_Click()
FrmTeste.Show
End Sub
Os códigos em VBA:
Private Sub TextBox1_Change()
TextBox1.Width = 150
TextBox1.MultiLine = True
TextBox1.WordWrap = True
TextBox1.AutoSize = False
With Me.TextBox1
.Height = 80
End With
End Sub
Private Sub CommandButton1_Click()
Range("A1") = TextBox1.Value
End Sub
2006-02-18
Num newsgroup foi colocada a seguinte questão: "Quando peço os sub-totais de uma folha, só fica em bold o campo da 1ª coluna. O que eu pretendo é que toda a linha do sub-total fique em bold automaticamente".
Para que os valores correspondentes aos subtotais fiquem automaticamente em BOLD, quando usamos subtotais para analisar uma lista, podemos utilizar a Formatação Condicional:
Vejamos o exemplo:
Utilizando a Função RIGHT() na Formatação Condicional:
Faz-se a selecção do Range e na Formatação Condicional, em Condição, escolhe-se "Formula Is" e digita-se a fórmula =RIGHT($A1;5)="Total", abre-se o campo Format e escolhe-se Bold:
O resultado:
Para que os valores correspondentes aos subtotais fiquem automaticamente em BOLD, quando usamos subtotais para analisar uma lista, podemos utilizar a Formatação Condicional:
Vejamos o exemplo:
Utilizando a Função RIGHT() na Formatação Condicional:
Faz-se a selecção do Range e na Formatação Condicional, em Condição, escolhe-se "Formula Is" e digita-se a fórmula =RIGHT($A1;5)="Total", abre-se o campo Format e escolhe-se Bold:
O resultado:
2006-02-11
Num newsgroup, foi feita a seguinte pergunta: Será que é possivel num Range em que tenho números (1,2,3,4,5, etc.) acrescentar letras atrás (COL1,COL2,COL3,COL4,COL5, etc.) sem editar célula a célula?
Selecciona-se o Range pretendido:
Executa-se a macro:
O resultado:
O Código do exemplo, em VBA:
Option Explicit
Sub AdicionaTexto()
Dim rng As Range
Dim rngCell As Range
Const sCHARACTER As String = "COL"
On Error GoTo Exit_AdicionaTexto
Set rng = ActiveWindow.RangeSelection
For Each rngCell In rng.Cells
If IsEmpty(rngCell.Value) = False Then
rngCell.Value = sCHARACTER & rngCell.Value
End If
Next rngCell
Exit_AdicionaTexto:
Set rngCell = Nothing
Set rng = Nothing
End Sub
Selecciona-se o Range pretendido:
Executa-se a macro:
O resultado:
O Código do exemplo, em VBA:
Option Explicit
Sub AdicionaTexto()
Dim rng As Range
Dim rngCell As Range
Const sCHARACTER As String = "COL"
On Error GoTo Exit_AdicionaTexto
Set rng = ActiveWindow.RangeSelection
For Each rngCell In rng.Cells
If IsEmpty(rngCell.Value) = False Then
rngCell.Value = sCHARACTER & rngCell.Value
End If
Next rngCell
Exit_AdicionaTexto:
Set rngCell = Nothing
Set rng = Nothing
End Sub
2006-02-06
Se pretendermos efectuar um cálculo para obter a diferença entre dois horários e sabermos o resultado em minutos, podemos utilizar, por exemplo, os seguintes métodos:
E se a hora final for inferior à hora inicial, como no caso de a hora final ser já depois da meia-noite? Aqui, podemos utilizar a seguinte fórmula:
E se a hora final for inferior à hora inicial, como no caso de a hora final ser já depois da meia-noite? Aqui, podemos utilizar a seguinte fórmula:
Subscrever:
Mensagens (Atom)