Function Captalize(X)
Dim Temp$, C$, OldC$, i As Integer
If IsNull(X) Then
Exit Function
Else
Let Temp$ = CStr(LCase(X))
Let OldC$ = " "
For i = 1 To Len(Temp$)
Let C$ = Mid$(Temp$, i, 1)
If C$ >= "a" And C$ <= "z" And (OldC$ < "a" Or OldC$ > "z") Then
Mid$(Temp$, i, 1) = UCase$(C$)
End If
Let OldC$ = C$
Next i
Let Proper = Temp$
End If
End Function
Mostrando postagens com marcador VBA. Mostrar todas as postagens
Mostrando postagens com marcador VBA. Mostrar todas as postagens
VBA - Criando Menus Personalizados
Sub criar_menu()
'Declarando as variáveis
Dim MenuObject As CommandBarPopup
Dim MenuItem As Object
Dim SubMenuItem As Object
'Atribui o valor da variável
Set MenuObject = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, before:=10, temporary:=True)
MenuObject.Caption = "Meu Menu Expert"
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
'Nome do botão
MenuItem.Caption = "Cliente"
'Separação por grupo
MenuItem.BeginGroup = True
'Nome da macro que irá executar
MenuItem.OnAction = "Cliente1"
'Ícone que aparecerá no botão
MenuItem.FaceId = "18"
End Sub
Sub Cliente1()
MsgBox "Bem vindos ao Site que Ama o Excel"
End Sub
'Declarando as variáveis
Dim MenuObject As CommandBarPopup
Dim MenuItem As Object
Dim SubMenuItem As Object
'Atribui o valor da variável
Set MenuObject = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, before:=10, temporary:=True)
MenuObject.Caption = "Meu Menu Expert"
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
'Nome do botão
MenuItem.Caption = "Cliente"
'Separação por grupo
MenuItem.BeginGroup = True
'Nome da macro que irá executar
MenuItem.OnAction = "Cliente1"
'Ícone que aparecerá no botão
MenuItem.FaceId = "18"
End Sub
Sub Cliente1()
MsgBox "Bem vindos ao Site que Ama o Excel"
End Sub
Criar Botões em VBA
Insira este código em um novo módulo e tecle F5
Sub Criar_Botões()
Dim botão As Button
Dim bot As Range
ActiveSheet.Buttons.Delete
For i = 1 To 5
Set bot = ActiveSheet.Range(Cells(i, 5), Cells(i, 5))
Set botão = _
ActiveSheet.Buttons.Add(bot.Left, bot.Top, bot.Width, bot.Height)
With botão
.OnAction = "Rotina" & i
.Caption = "Rotina " & i
.Name = "Nome" & i
End With
Next i
End Sub
Sub Criar_Botões()
Dim botão As Button
Dim bot As Range
ActiveSheet.Buttons.Delete
For i = 1 To 5
Set bot = ActiveSheet.Range(Cells(i, 5), Cells(i, 5))
Set botão = _
ActiveSheet.Buttons.Add(bot.Left, bot.Top, bot.Width, bot.Height)
With botão
.OnAction = "Rotina" & i
.Caption = "Rotina " & i
.Name = "Nome" & i
End With
Next i
End Sub
Tratar Erros em VBA
A Instrução On Error
Para fazer o tratamento de erros em vba utilizamos a instrução On Error, esta instrução tem diferentes formatos e opções, vamos passar uma breve explicação de como funciona.
On Error GoTo Line
Ativa o tratamento de erro que inicia na linha especifícada pelo argumento line.
On Error Resume Next
Esta instrução é utilizada para ignorar erros durante a execução.
On Error GoTo 0
Desativa qualque manipulador de erro ativo no procedimento.
Function tratarErro()
'Declaração da variável
Dim x
'Cria o tratamento do erro
On Error GoTo erro
'Chama a variável criando a função
x = 10 / 0
'Finaliza o erro
Exit Function
'Demonstra o erro
erro:
MsgBox "Erro na divisão por " & Erl
End Function
Para acompanhar a depuração aperte a tecla F8.
Para fazer o tratamento de erros em vba utilizamos a instrução On Error, esta instrução tem diferentes formatos e opções, vamos passar uma breve explicação de como funciona.
On Error GoTo Line
Ativa o tratamento de erro que inicia na linha especifícada pelo argumento line.
On Error Resume Next
Esta instrução é utilizada para ignorar erros durante a execução.
On Error GoTo 0
Desativa qualque manipulador de erro ativo no procedimento.
Function tratarErro()
'Declaração da variável
Dim x
'Cria o tratamento do erro
On Error GoTo erro
'Chama a variável criando a função
x = 10 / 0
'Finaliza o erro
Exit Function
'Demonstra o erro
erro:
MsgBox "Erro na divisão por " & Erl
End Function
Para acompanhar a depuração aperte a tecla F8.
Evento Change em Excel
Já imaginou em alterar um dado quando outro é inserido? isso é possivel em Excel você sabia?
Então vamos ao código
Private Sub Worksheet_Change(ByVal Target As Range)
Dim linha As Integer
Dim coluna As Integer
' Usamos o argumento Target para saber qual campo foi alterado.
coluna = Target.Column
linha = Target.Row
' Executa a função calculo se campo B5 foi alterado.
If (linha = 5 And coluna = 2) Then
ocultar
End If
End Sub
Function ocultar()
Rows("7:7").Select
Selection.EntireRow.Hidden = True
'altere para false se quiser reexibir
End Function
Insira este código dentro da planilha que você utilizará pelo alt+f11
Então vamos ao código
Private Sub Worksheet_Change(ByVal Target As Range)
Dim linha As Integer
Dim coluna As Integer
' Usamos o argumento Target para saber qual campo foi alterado.
coluna = Target.Column
linha = Target.Row
' Executa a função calculo se campo B5 foi alterado.
If (linha = 5 And coluna = 2) Then
ocultar
End If
End Sub
Function ocultar()
Rows("7:7").Select
Selection.EntireRow.Hidden = True
'altere para false se quiser reexibir
End Function
Insira este código dentro da planilha que você utilizará pelo alt+f11
Função ano Bissexto
Function Bissexto(intAno As Integer) As Boolean
'
' verifica se um ano é bissexto
'
Bissexto = False
If intAno Mod 4 = 0 Then
If intAno Mod 100 = 0 Then
If intAno Mod 400 = 0 Then
Bissexto = True
End If
Else
Bissexto = True
End If
End If
End Function
'
' verifica se um ano é bissexto
'
Bissexto = False
If intAno Mod 4 = 0 Then
If intAno Mod 100 = 0 Then
If intAno Mod 400 = 0 Then
Bissexto = True
End If
Else
Bissexto = True
End If
End If
End Function
Criando Funções em VBA - Datas
Dias corridos entre datas em VBA
Function DiasCorridosEntreDatas(DataInicial As Date, DataFinal As Date) As Long
DiasCorridosEntreDatas = (DataFinal - DataInicial)
End Function
Dias úteis entre datas em VBA
Function DiasUteisEntreDatas(DataInicial As Date, DataFinal As Date) As Double
Dim Idatas As Date
Dim i As Double
i = 0
For Idatas = DataInicial To DataFinal
If ÉDiaUtil(Idatas) Then i = i + 1
Next
DiasUteisEntreDatas = i
End Function
Dias corridos após dias úteis em VBA
Function DiasCorridosAposDiasUteis(Data As Date, DiasUteis As Long) As Long
DiasCorridosAposDiasUteis = DiasCorridosEntreDatas(Data, DataAposDiasUteis(Data, DiasUteis))
End Function
Dias úteis após dias corridos em VBA
Function DiasUteisAposDiasCorridos(Data As Date, DiasCorridos As Long) As Long
DiasUteisAposDiasCorridos = DiasUteisEntreDatas(Data, Data + DiasCorridos)
End Function
Data após dias corridos em VBA
Function DataAposDiasCorridos(Data As Date, dias As Long) As String
DataAposDiasCorridos = Data + dias
End Function
Data após dias úteis em VBA
Function DataAposDiasUteis(Data As Date, dias As Long)
Dim i As Long
Dim DataUtil As Date
i = 0
DataUtil = Data
Do While Abs(i) < Abs(dias)
If ÉDiaUtil(DataUtil) Then i = i + Sgn(dias)
DataUtil = DataUtil + Sgn(dias)
Loop
Do While Not ÉDiaUtil(DataUtil)
DataUtil = DataUtil + Sgn(dias + 0.5)
Loop
DataAposDiasUteis = DataUtil
End Function
Próximo dia Útil em VBA
Function ProximoDiaUtil(Data As Date) As Date
Dim DataUtil As Date
DataUtil = Data + 1
Do While Not ÉDiaUtil(DataUtil)
DataUtil = DataUtil + 1
Loop
ProximoDiaUtil = DataUtil
End Function
Primeiro dia útil do mês em VBA
Function PrimeiroDiaUtilMes(Data As Date) As Date
Dim PrimeiroDiaMes As Date
PrimeiroDiaMes = CDate("01/" & Str(Month(Data)) & Str(Year(Data)))
PrimeiroDiaUtilMes = IIf(ÉDiaUtil(PrimeiroDiaMes), _
PrimeiroDiaMes, ProximoDiaUtil(PrimeiroDiaMes))
End Function
Ultimo dia útil do mês em VBA
Function UltimoDiaUtilMes(Data As Date) As Date
Dim PrimeiroDiaMesSeguinte As Date
If Month(Data) < 12 Then
PrimeiroDiaMesSeguinte = PrimeiroDiaUtilMes(CDate("01/" _
& Str(Month(Data) + 1) & Str(Year(Data))))
Else
PrimeiroDiaMesSeguinte = PrimeiroDiaUtilMes(CDate("01/01" _
& Str(Year(Data) + 1)))
End If
UltimoDiaUtilMes = DataAposDiasUteis(PrimeiroDiaMesSeguinte, -1)
End Function
Função para saber se é fim de semana em VBA
Function ÉFimSemana(Data As Date) As Boolean
If WeekDay(Data, vbMonday) < 6 Then
ÉFimSemana = False
Else
ÉFimSemana = True
End If
End Function
Função para saber se é Sábado em VBA
Function ÉSábado(Data As Date) As Boolean
If WeekDay(Data) = 7 Then
ÉSábado = True
Else
ÉSábado = False
End If
End Function
Função para saber se é Domingo em VBA
Function ÉDomingo(Data As Date) As Boolean
If WeekDay(Data) = 1 Then
ÉDomingo = True
Else
ÉDomingo = False
End If
End Function
Função em VBA para saber se é dia útil
Function ÉDiaUtil(Data As Date) As Boolean
If Not ÉFeriado(Data) And Not ÉFimSemana(Data) And Not ÉPascoa(CDate(Data)) Then
ÉDiaUtil = True
Else
ÉDiaUtil = False
End If
End Function
Função em VBA para saber qual o dia da semana
Function DiaDaSemana(Data As Date) As String
Select Case WeekDay(Data, vbMonday)
Case 1
DiaDaSemana = "Segunda"
Case 2
DiaDaSemana = "Terça"
Case 3
DiaDaSemana = "Quarta"
Case 4
DiaDaSemana = "Quinta"
Case 5
DiaDaSemana = "Sexta"
Case 6
DiaDaSemana = "Sábado"
Case 7
DiaDaSemana = "Domingo"
End Select
End Function
Função em VBA para saber o nome do mês
Function NomedoMes(iMesAtual As Integer)
Dim sNomeMes As String
Select Case iMesAtual
Case 1
sNomeMes = "Janeiro"
Case 2
sNomeMes = "Fevereiro"
Case 3
sNomeMes = "Março"
Case 4
sNomeMes = "Abril"
Case 5
sNomeMes = "Maio"
Case 6
sNomeMes = "Junho"
Case 7
sNomeMes = "Julho"
Case 8
sNomeMes = "Agosto"
Case 9
sNomeMes = "Setembro"
Case 10
sNomeMes = "Outubro"
Case 11
sNomeMes = "Novembro"
Case 12
sNomeMes = "Dezembro"
End Select
NomedoMes = sNomeMes
End Function
Função em VBA para determinar os feriados, muito útil.
Function ÉFeriado(sbsDia) As Boolean
Dim kcont As Integer, stFer(8) As String
stFer(1) = "1/1"
stFer(2) = "21/4"
stFer(3) = "1/5"
stFer(4) = "7/9"
stFer(5) = "12/10"
stFer(6) = "2/11"
stFer(7) = "15/11"
stFer(8) = "25/12"
For kcont = 1 To 8
If Day(sbsDia) & "/" & Month(sbsDia) = stFer(kcont) Then
ÉFeriado = True
Exit Function
End If
Next kcont
End Function
Função em VBA para saber se é Pascoa
Function ÉPascoa(sbsPascoa As Single) As Boolean
Dim sn As Integer, sa, sb, sc, sd, se, sf, sg, sh, si, sk, sl, sm, sp, sq As Single
Dim sDia, sMes, sDiaCarnaval, sDiaCarn, sMesCarnaval As Single
Dim stDiadePascoa As String, sDiadePascoa As Single, sDiaCorpChr As Single
sn = Year(sbsPascoa)
sa = sn - Int(sn / 19) * 19
sb = Int(sn / 100)
sc = sn - sb * 100
sd = Int(sb / 4)
se = sb - sd * 4
sf = Int((sb + 8) / 25)
sg = Int((sb - sf + 1) / 3)
sh = (19 * sa + sb - sd - sg + 15) - Int((19 * sa + sb - sd - sg + 15) / 30) * 30
si = Int(sc / 4)
sk = sc - si * 4
sl = (32 + 2 * se + 2 * si - sh - sk) - Int((32 + 2 * se + 2 * si - sh - sk) / 7) * 7
sm = Int((sa + 11 * sh + 22 * sl) / 451)
sp = Int((sh + sl - 7 * sm + 114) / 31)
sq = sh + sl - 7 * sm + 114 - sp * 31
sDia = sq + 1 'Domingo de Páscoa
sMes = sp 'Mês da Páscoa
stDiadePascoa = sDia & "/" & sMes & "/" & sn
sDiadePascoa = Int(CDate(stDiadePascoa))
sDiaCarnaval = sDiadePascoa - 47
sDiaCarn = sDiadePascoa - 48
sDiaCorpChr = sDiadePascoa + 60
If Day(sbsPascoa) = sDia And Month(sbsPascoa) = sp Then
ÉPascoa = True
End If
If Day(sbsPascoa) = sDia - 2 And Month(sbsPascoa) = sp Then
ÉPascoa = True
'Paixão de Cristo
End If
If Day(sbsPascoa) = Day(sDiaCarnaval) And Month(sbsPascoa) = Month(sDiaCarnaval) Then
ÉPascoa = True
'Terça Feira de Carnaval
End If
If Day(sbsPascoa) = Day(sDiaCorpChr) And Month(sbsPascoa) = Month(sDiaCorpChr) Then
ÉPascoa = True
'Corpus Christi
End If
If Day(sbsPascoa) = Day(sDiaCarn) And Month(sbsPascoa) = Month(sDiaCarn) Then
ÉPascoa = True
'Segunda feira de Carnaval
End If
End Function
Função para saber que idade a pessoa tem em VBA
Function QueIdade(dn)
QueIdade = Int((Date - dn) / 365.25)
QueIdade = IIf(QueIdade < 1, Format(QueIdade, "# anos"), Format(QueIdade, "# anos"))
End Function
Function DiasCorridosEntreDatas(DataInicial As Date, DataFinal As Date) As Long
DiasCorridosEntreDatas = (DataFinal - DataInicial)
End Function
Dias úteis entre datas em VBA
Function DiasUteisEntreDatas(DataInicial As Date, DataFinal As Date) As Double
Dim Idatas As Date
Dim i As Double
i = 0
For Idatas = DataInicial To DataFinal
If ÉDiaUtil(Idatas) Then i = i + 1
Next
DiasUteisEntreDatas = i
End Function
Dias corridos após dias úteis em VBA
Function DiasCorridosAposDiasUteis(Data As Date, DiasUteis As Long) As Long
DiasCorridosAposDiasUteis = DiasCorridosEntreDatas(Data, DataAposDiasUteis(Data, DiasUteis))
End Function
Dias úteis após dias corridos em VBA
Function DiasUteisAposDiasCorridos(Data As Date, DiasCorridos As Long) As Long
DiasUteisAposDiasCorridos = DiasUteisEntreDatas(Data, Data + DiasCorridos)
End Function
Data após dias corridos em VBA
Function DataAposDiasCorridos(Data As Date, dias As Long) As String
DataAposDiasCorridos = Data + dias
End Function
Data após dias úteis em VBA
Function DataAposDiasUteis(Data As Date, dias As Long)
Dim i As Long
Dim DataUtil As Date
i = 0
DataUtil = Data
Do While Abs(i) < Abs(dias)
If ÉDiaUtil(DataUtil) Then i = i + Sgn(dias)
DataUtil = DataUtil + Sgn(dias)
Loop
Do While Not ÉDiaUtil(DataUtil)
DataUtil = DataUtil + Sgn(dias + 0.5)
Loop
DataAposDiasUteis = DataUtil
End Function
Próximo dia Útil em VBA
Function ProximoDiaUtil(Data As Date) As Date
Dim DataUtil As Date
DataUtil = Data + 1
Do While Not ÉDiaUtil(DataUtil)
DataUtil = DataUtil + 1
Loop
ProximoDiaUtil = DataUtil
End Function
Primeiro dia útil do mês em VBA
Function PrimeiroDiaUtilMes(Data As Date) As Date
Dim PrimeiroDiaMes As Date
PrimeiroDiaMes = CDate("01/" & Str(Month(Data)) & Str(Year(Data)))
PrimeiroDiaUtilMes = IIf(ÉDiaUtil(PrimeiroDiaMes), _
PrimeiroDiaMes, ProximoDiaUtil(PrimeiroDiaMes))
End Function
Ultimo dia útil do mês em VBA
Function UltimoDiaUtilMes(Data As Date) As Date
Dim PrimeiroDiaMesSeguinte As Date
If Month(Data) < 12 Then
PrimeiroDiaMesSeguinte = PrimeiroDiaUtilMes(CDate("01/" _
& Str(Month(Data) + 1) & Str(Year(Data))))
Else
PrimeiroDiaMesSeguinte = PrimeiroDiaUtilMes(CDate("01/01" _
& Str(Year(Data) + 1)))
End If
UltimoDiaUtilMes = DataAposDiasUteis(PrimeiroDiaMesSeguinte, -1)
End Function
Função para saber se é fim de semana em VBA
Function ÉFimSemana(Data As Date) As Boolean
If WeekDay(Data, vbMonday) < 6 Then
ÉFimSemana = False
Else
ÉFimSemana = True
End If
End Function
Função para saber se é Sábado em VBA
Function ÉSábado(Data As Date) As Boolean
If WeekDay(Data) = 7 Then
ÉSábado = True
Else
ÉSábado = False
End If
End Function
Função para saber se é Domingo em VBA
Function ÉDomingo(Data As Date) As Boolean
If WeekDay(Data) = 1 Then
ÉDomingo = True
Else
ÉDomingo = False
End If
End Function
Função em VBA para saber se é dia útil
Function ÉDiaUtil(Data As Date) As Boolean
If Not ÉFeriado(Data) And Not ÉFimSemana(Data) And Not ÉPascoa(CDate(Data)) Then
ÉDiaUtil = True
Else
ÉDiaUtil = False
End If
End Function
Função em VBA para saber qual o dia da semana
Function DiaDaSemana(Data As Date) As String
Select Case WeekDay(Data, vbMonday)
Case 1
DiaDaSemana = "Segunda"
Case 2
DiaDaSemana = "Terça"
Case 3
DiaDaSemana = "Quarta"
Case 4
DiaDaSemana = "Quinta"
Case 5
DiaDaSemana = "Sexta"
Case 6
DiaDaSemana = "Sábado"
Case 7
DiaDaSemana = "Domingo"
End Select
End Function
Função em VBA para saber o nome do mês
Function NomedoMes(iMesAtual As Integer)
Dim sNomeMes As String
Select Case iMesAtual
Case 1
sNomeMes = "Janeiro"
Case 2
sNomeMes = "Fevereiro"
Case 3
sNomeMes = "Março"
Case 4
sNomeMes = "Abril"
Case 5
sNomeMes = "Maio"
Case 6
sNomeMes = "Junho"
Case 7
sNomeMes = "Julho"
Case 8
sNomeMes = "Agosto"
Case 9
sNomeMes = "Setembro"
Case 10
sNomeMes = "Outubro"
Case 11
sNomeMes = "Novembro"
Case 12
sNomeMes = "Dezembro"
End Select
NomedoMes = sNomeMes
End Function
Função em VBA para determinar os feriados, muito útil.
Function ÉFeriado(sbsDia) As Boolean
Dim kcont As Integer, stFer(8) As String
stFer(1) = "1/1"
stFer(2) = "21/4"
stFer(3) = "1/5"
stFer(4) = "7/9"
stFer(5) = "12/10"
stFer(6) = "2/11"
stFer(7) = "15/11"
stFer(8) = "25/12"
For kcont = 1 To 8
If Day(sbsDia) & "/" & Month(sbsDia) = stFer(kcont) Then
ÉFeriado = True
Exit Function
End If
Next kcont
End Function
Função em VBA para saber se é Pascoa
Function ÉPascoa(sbsPascoa As Single) As Boolean
Dim sn As Integer, sa, sb, sc, sd, se, sf, sg, sh, si, sk, sl, sm, sp, sq As Single
Dim sDia, sMes, sDiaCarnaval, sDiaCarn, sMesCarnaval As Single
Dim stDiadePascoa As String, sDiadePascoa As Single, sDiaCorpChr As Single
sn = Year(sbsPascoa)
sa = sn - Int(sn / 19) * 19
sb = Int(sn / 100)
sc = sn - sb * 100
sd = Int(sb / 4)
se = sb - sd * 4
sf = Int((sb + 8) / 25)
sg = Int((sb - sf + 1) / 3)
sh = (19 * sa + sb - sd - sg + 15) - Int((19 * sa + sb - sd - sg + 15) / 30) * 30
si = Int(sc / 4)
sk = sc - si * 4
sl = (32 + 2 * se + 2 * si - sh - sk) - Int((32 + 2 * se + 2 * si - sh - sk) / 7) * 7
sm = Int((sa + 11 * sh + 22 * sl) / 451)
sp = Int((sh + sl - 7 * sm + 114) / 31)
sq = sh + sl - 7 * sm + 114 - sp * 31
sDia = sq + 1 'Domingo de Páscoa
sMes = sp 'Mês da Páscoa
stDiadePascoa = sDia & "/" & sMes & "/" & sn
sDiadePascoa = Int(CDate(stDiadePascoa))
sDiaCarnaval = sDiadePascoa - 47
sDiaCarn = sDiadePascoa - 48
sDiaCorpChr = sDiadePascoa + 60
If Day(sbsPascoa) = sDia And Month(sbsPascoa) = sp Then
ÉPascoa = True
End If
If Day(sbsPascoa) = sDia - 2 And Month(sbsPascoa) = sp Then
ÉPascoa = True
'Paixão de Cristo
End If
If Day(sbsPascoa) = Day(sDiaCarnaval) And Month(sbsPascoa) = Month(sDiaCarnaval) Then
ÉPascoa = True
'Terça Feira de Carnaval
End If
If Day(sbsPascoa) = Day(sDiaCorpChr) And Month(sbsPascoa) = Month(sDiaCorpChr) Then
ÉPascoa = True
'Corpus Christi
End If
If Day(sbsPascoa) = Day(sDiaCarn) And Month(sbsPascoa) = Month(sDiaCarn) Then
ÉPascoa = True
'Segunda feira de Carnaval
End If
End Function
Função para saber que idade a pessoa tem em VBA
Function QueIdade(dn)
QueIdade = Int((Date - dn) / 365.25)
QueIdade = IIf(QueIdade < 1, Format(QueIdade, "# anos"), Format(QueIdade, "# anos"))
End Function
Modificar tamanho DropDown em VBA
Muitas vezes criamos uma validação em Excel e o campo DropDown fica pequeno, para isso podemos utilizar o VBA e resolver nossos problemas.
Para modificar o tamanho do campo validado nada melhor que utilizar o evento Selection
Change(), evento que é acionado sempre que selecionamos uma determinada célula.
No módulo privado EstaPasta_de_trabalho selecione o Workbook_SheetSelectionChange()
e insira o código abaixo;
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Const dFixedPos As Double = "0.2"
Const dFixWidth As Double = "12.0" '
Dim vld As Validation
Dim lDpdLine As Long
If Not prvTarget Is Nothing Then
If Not oDpd Is Nothing Then
If oDpd.Value = 0 Then
prvTarget.Value = vbNullString
Else
prvTarget.Value = Range(Mid(sFml1, 2)).Item(oDpd.Value)
End If
Set prvTarget = Nothing
End If
End If
On Error Resume Next
oDpd.Delete
sFml1 = vbNullString
Set oDpd = Nothing
On Error GoTo 0
If Target.Count > 1 Then
Set oDpd = Nothing
Exit Sub
End If
Set vld = Target.Validation
On Error GoTo Terminate
sFml1 = vld.Formula1
On Error GoTo 0
Set prvTarget = Target
lDpdLine = Plan1.Range(Mid(sFml1, 2)).Rows.Count
With Target
Set oDpd = ActiveSheet.DropDowns.Add( _
.Left - dFixedPos, _
.Top - dFixedPos, _
.Width + dFixWidth + dFixedPos * 2, _
.Height + dFixedPos * 2)
End With
With oDpd
.ListFillRange = sFml1
.DropDownLines = lDpdLine
.Display3DShading = True
End With
Terminate:
End Sub
Para modificar o tamanho do campo validado nada melhor que utilizar o evento Selection
Change(), evento que é acionado sempre que selecionamos uma determinada célula.
No módulo privado EstaPasta_de_trabalho selecione o Workbook_SheetSelectionChange()
e insira o código abaixo;
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Const dFixedPos As Double = "0.2"
Const dFixWidth As Double = "12.0" '
Dim vld As Validation
Dim lDpdLine As Long
If Not prvTarget Is Nothing Then
If Not oDpd Is Nothing Then
If oDpd.Value = 0 Then
prvTarget.Value = vbNullString
Else
prvTarget.Value = Range(Mid(sFml1, 2)).Item(oDpd.Value)
End If
Set prvTarget = Nothing
End If
End If
On Error Resume Next
oDpd.Delete
sFml1 = vbNullString
Set oDpd = Nothing
On Error GoTo 0
If Target.Count > 1 Then
Set oDpd = Nothing
Exit Sub
End If
Set vld = Target.Validation
On Error GoTo Terminate
sFml1 = vld.Formula1
On Error GoTo 0
Set prvTarget = Target
lDpdLine = Plan1.Range(Mid(sFml1, 2)).Rows.Count
With Target
Set oDpd = ActiveSheet.DropDowns.Add( _
.Left - dFixedPos, _
.Top - dFixedPos, _
.Width + dFixWidth + dFixedPos * 2, _
.Height + dFixedPos * 2)
End With
With oDpd
.ListFillRange = sFml1
.DropDownLines = lDpdLine
.Display3DShading = True
End With
Terminate:
End Sub
Funções para SQL
São Utilizadas para determinar quantidade de registros, totais, médias ou dados estatísticos.
Função SUM: Utilizada para somarmos uma determinada coluna de valor numérico ou monetário. Para utilizar esta função no SQL devemos "apelidar" a nova coluna que será criada seguido da palavra AS. Ex: SUM(salários) AS TotalSalário. A coluna TotalSalário será temporária e assim que fecharmos a consulta ela não mais existirá.
Exemplo:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT superior, sum(salário) as TotalSalários FROM [dados2$] GROUP BY superior;")
Função AVG: Assim como na função SUM sua utilidade é de calcular a média de certo valor monetária de uma coluna que satisfaça uma certa condição. No Exemplo anterior utilizamos a Cláusula GROUP BY para agruparmos quantos supervisores existiam na empresa; em seguida somamos os salários dos seus subordinados. Agora iremos calcular o salário médio dos subordinados.
Exemplo:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT superior, SUM(salário) as TotalSalários , AVG(salário) AS MédiaSalários FROM [dados2$] GROUP BY superior;")
Função COUNT: Utilizada para contar o número de registros. Neste exemplo utilizamos para saber o número de funcionários que cada supervisor comanda.
Exemplo:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT superior, SUM(salário) as TotalSalários ,AVG(salário) AS MédiaSalários , COUNT(salário) AS QtSalários FROM [dados2$] GROUP BY superior;")
Função MIN e MAX: Utilizadas para obter o menor e o maior registro respectivamente. Neste exemplo conseguimos saber o menor e o maior salário dos subordinados dos respectivos supervisores.
Exemplo:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT superior, SUM(salário) as TotalSalários ,AVG(salário) AS MédiaSalários , COUNT(salário) AS QtSalários , MIN(salário) AS MinSalários, MAX(salário) AS MaxSalários FROM [dados2$] GROUP BY superior;")
Consulta UNION: É usada para combinar o conjunto de registros de duas ou mais tabelas com campos idênticos. Sua sitaxe é a seguinte: "SELECT * FROM Tabela1 UNION ALL SELECT * FROM Tabela2;
Função SUM: Utilizada para somarmos uma determinada coluna de valor numérico ou monetário. Para utilizar esta função no SQL devemos "apelidar" a nova coluna que será criada seguido da palavra AS. Ex: SUM(salários) AS TotalSalário. A coluna TotalSalário será temporária e assim que fecharmos a consulta ela não mais existirá.
Exemplo:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT superior, sum(salário) as TotalSalários FROM [dados2$] GROUP BY superior;")
Função AVG: Assim como na função SUM sua utilidade é de calcular a média de certo valor monetária de uma coluna que satisfaça uma certa condição. No Exemplo anterior utilizamos a Cláusula GROUP BY para agruparmos quantos supervisores existiam na empresa; em seguida somamos os salários dos seus subordinados. Agora iremos calcular o salário médio dos subordinados.
Exemplo:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT superior, SUM(salário) as TotalSalários , AVG(salário) AS MédiaSalários FROM [dados2$] GROUP BY superior;")
Função COUNT: Utilizada para contar o número de registros. Neste exemplo utilizamos para saber o número de funcionários que cada supervisor comanda.
Exemplo:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT superior, SUM(salário) as TotalSalários ,AVG(salário) AS MédiaSalários , COUNT(salário) AS QtSalários FROM [dados2$] GROUP BY superior;")
Função MIN e MAX: Utilizadas para obter o menor e o maior registro respectivamente. Neste exemplo conseguimos saber o menor e o maior salário dos subordinados dos respectivos supervisores.
Exemplo:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT superior, SUM(salário) as TotalSalários ,AVG(salário) AS MédiaSalários , COUNT(salário) AS QtSalários , MIN(salário) AS MinSalários, MAX(salário) AS MaxSalários FROM [dados2$] GROUP BY superior;")
Consulta UNION: É usada para combinar o conjunto de registros de duas ou mais tabelas com campos idênticos. Sua sitaxe é a seguinte: "SELECT * FROM Tabela1 UNION ALL SELECT * FROM Tabela2;
Instruções SQL para realização de Consultas
SQL: Estrutura da Linguagem Query é a linguagem padrão para comunicar-se com um banco de dados.Utilizamos esta linguagem para extrair de uma tabela em um formato legível,de acordo com a solicitação do usuário informações que venha satisfazer suas necessidades. As consultas são ferramentas essenciais em qualquer sistema de gerenciamento de banco de dados, pois possibilitam selecionar registros, atualizar tabelas, editar incluir registros.
Comando SELECT: É o principal comando do SQL, Usado principalmente em consultas de seleção. Sua sintaxe é a seguinte:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT * FROM [dados$];")
Onde:SELECT é a instrução; o asterisco( * ) representa toda tabela; FROM [dados$], da tabela dados.
Cláusula ORDER BY: A critério do usuário pode-se ordenar uma tabela simultaneamente quando da execução de uma consulta, para isto basta utilizar o comando ORDER BY. Pode-se ordenar na ascendente (ASC) ou na Descendente (DESC). A sintaxe é a seguinte:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT * FROM [dados$] ORDER BY nome DESC;")
Cláusula WHERE: Tem alguns casos que precisamos filtrar algum registro em algum parametro específico. Por exemplo, precisamos filtrar todos nomes "José", neste caso utilizamos a cláusula WHERE. A cláusula WHERE aceita operadores OR (ou) e AND (e) para trabalho com expressões.
Estrutura JOIN...ON: Podemos utilizar mais de uma tabela para efetuar uma consulta complexa. No nosso caso prático temos duas tabelas com um campo em comum, "nº" ; Numa tabela consta o nome, cargo e bairro; e na outra consta o superior, salário e dataadmissão. Desejamos então saber quais os nomes da tabela 1 tem como superior imediato o sr. João. Devemos então fazer uma associação das duas tabelas com a estrutura JOIN...ON. As tabelas são incluidas na Cláusula JOIN e os
critérios de associação são colocados na cláusula ON. A três tipos de associações: INNER (Equivalência), LEFT (externa à esquerda) e RIGHT( Externa à direita). As associações externas são as que retornam todos os valores de uma tabela e apenas os correspondentes de outra.
Palavra Chave DISTINCT: Esta palavra chave faz com que sejam eliminadas linhas repetidas com base nos valores das linhas da consulta. Se utiliza esta palavra chave para sabermos quantos nomes direntes exisem em uma determinada tabela.
Modificadores TOP e PERCENT: Ambos limitam o conjunto de resultados de uma consulta. Utiliza-se para conhecer-se como por exemplo os maiores salários de uma empresa, os maiores clientes etc.
Utilizarmos a consulta para conhecer os 03 maiores. Obs: Para que a consulta seja verdadeira é necessário ordernarmos a coluna que servirá de resposta, no caso salario.
Cláusula GROUP BY: Serve agrupar dados.
Comando SELECT: É o principal comando do SQL, Usado principalmente em consultas de seleção. Sua sintaxe é a seguinte:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT * FROM [dados$];")
Onde:SELECT é a instrução; o asterisco( * ) representa toda tabela; FROM [dados$], da tabela dados.
Cláusula ORDER BY: A critério do usuário pode-se ordenar uma tabela simultaneamente quando da execução de uma consulta, para isto basta utilizar o comando ORDER BY. Pode-se ordenar na ascendente (ASC) ou na Descendente (DESC). A sintaxe é a seguinte:
Set MinhaTabela = MeuBD.OpenRecordset("SELECT * FROM [dados$] ORDER BY nome DESC;")
Cláusula WHERE: Tem alguns casos que precisamos filtrar algum registro em algum parametro específico. Por exemplo, precisamos filtrar todos nomes "José", neste caso utilizamos a cláusula WHERE. A cláusula WHERE aceita operadores OR (ou) e AND (e) para trabalho com expressões.
Estrutura JOIN...ON: Podemos utilizar mais de uma tabela para efetuar uma consulta complexa. No nosso caso prático temos duas tabelas com um campo em comum, "nº" ; Numa tabela consta o nome, cargo e bairro; e na outra consta o superior, salário e dataadmissão. Desejamos então saber quais os nomes da tabela 1 tem como superior imediato o sr. João. Devemos então fazer uma associação das duas tabelas com a estrutura JOIN...ON. As tabelas são incluidas na Cláusula JOIN e os
critérios de associação são colocados na cláusula ON. A três tipos de associações: INNER (Equivalência), LEFT (externa à esquerda) e RIGHT( Externa à direita). As associações externas são as que retornam todos os valores de uma tabela e apenas os correspondentes de outra.
Palavra Chave DISTINCT: Esta palavra chave faz com que sejam eliminadas linhas repetidas com base nos valores das linhas da consulta. Se utiliza esta palavra chave para sabermos quantos nomes direntes exisem em uma determinada tabela.
Modificadores TOP e PERCENT: Ambos limitam o conjunto de resultados de uma consulta. Utiliza-se para conhecer-se como por exemplo os maiores salários de uma empresa, os maiores clientes etc.
Utilizarmos a consulta para conhecer os 03 maiores. Obs: Para que a consulta seja verdadeira é necessário ordernarmos a coluna que servirá de resposta, no caso salario.
Cláusula GROUP BY: Serve agrupar dados.
Sheets expiration date
Have you thought sometimes pass their sheet to a friend, colleague or a third party and not knowing how they will use them, or worse appropriating their ideas? I put this down to a code where your spreadsheet will expire when the user closes it.
Private Sub Workbook_BeforeClose (Cancel As Boolean)
As Date Dim dtexp
'Select the date which will expire
dtexp = ("29/04/2011") 'here inhibit'
If Date> = # 1/11/2010 # Then 'turn this'
If Date> = dtexp Then 'inhibiting here'
ThisWorkbook.Saved = True
'If you want to send message only remove the single quote of the bottom line or customize
'MsgBox "This file is expired, if auto-delete!"
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
end If
end If
end Sub
** Note will not even to trash
Private Sub Workbook_BeforeClose (Cancel As Boolean)
As Date Dim dtexp
'Select the date which will expire
dtexp = ("29/04/2011") 'here inhibit'
If Date> = # 1/11/2010 # Then 'turn this'
If Date> = dtexp Then 'inhibiting here'
ThisWorkbook.Saved = True
'If you want to send message only remove the single quote of the bottom line or customize
'MsgBox "This file is expired, if auto-delete!"
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
end If
end If
end Sub
** Note will not even to trash
Unprotected multiple sheets at once
Below we reported a very simple way to unprotect multiple sheets at once in excel. It is a code in VBA where you only need to copy and paste our readers.
Note this tip we can use this code for several funionabilidades Excel such as: unprotect worksheets, protect worksheets, spreadsheets, hide, unhide worksheets, etc..
I hope you enjoyed it more this super tip Excel.
Sub unprotect_worksheets()
Dim i As Integer
'Loops in the standard of excel spreadsheets
'If more than 03 worksheets to unprotected change the number 3 to the desired amount
For i = 1 To 3
Sheets (i). Unprotect Password: = "123" 'where 123 is the password you
Next i
MsgBox "Worksheets unprotected successfully!" 'Optional message
end Sub
Note this tip we can use this code for several funionabilidades Excel such as: unprotect worksheets, protect worksheets, spreadsheets, hide, unhide worksheets, etc..
I hope you enjoyed it more this super tip Excel.
Sub unprotect_worksheets()
Dim i As Integer
'Loops in the standard of excel spreadsheets
'If more than 03 worksheets to unprotected change the number 3 to the desired amount
For i = 1 To 3
Sheets (i). Unprotect Password: = "123" 'where 123 is the password you
Next i
MsgBox "Worksheets unprotected successfully!" 'Optional message
end Sub
Suplementos em Excel - XLA
DEFINIÇÃO DA MICROSOFT
Os suplementos são programas que adicionam comandos e recursos opcionais ao Microsoft Excel.
Antes de usar um suplemento, você precisa instalá-lo no computador e, em seguida, carregá-lo
no Microsoft Excel. Por padrão, os suplementos (arquivos *.xla) são instalados na pasta Biblioteca
da pasta do Microsoft Excel. O carregamento de um suplemento disponibiliza o recurso no
Microsoft Excel e adiciona todos os comandos associados aos menus adequados. Os programas
suplementares listados na tabela a seguir são instalados, por padrão, na pasta Biblioteca, ou em
uma de suas subpastas, na pasta do Microsoft Excel. Se você não conseguir localizar determinado
suplemento no disco rígido ou em uma unidade da rede, poderá instalá-lo. Após instalar um
suplemento, será necessário usar o comando Suplementos (menu Ferramentas) para carregá-lo no
Microsoft Excel.
A partir dessa breve explicação vamos desenvolver nossa aplicação uma Agenda simples, porem muito funcional.
As Ferramentas necessárias
Para a criação de nossa Agenda de Tarefas precisaremos de um formulário para a inclusão e
consulta das tarefas agendadas , de uma planilha que servirá para armazenar as informações e ou-
tra planilha que servirá como relatório caso se deseje imprimir as anotações do dia.
O Formulário
Crie o formulário Agenda utilizando as especificações que fazem parte da Tabela a seguir:
Objeto Propriedade Ajuste
Formulário Name frmAgenda
Caption Anote Seus Afazeres e Lembretes para o ano de 2011
TextBox1 Name BoxDia
Font Takoma 10
TextAlign 2 - Center
TextBox2 Name BoxAnotações
Font Takoma 8
TextAlign 1 - Left
EnterKeyBehavior True
MultiLine True
TextBox3 Name BoxResumo
Font Takoma 8
TextAlign 1 - Left
EnterKeyBehavior True
MultiLine True
ScroollBars 3 - FmScrollBarsBoth
CommandButton1 Name CmdSair
Caption Incluir/Alterar
CommandButton2 Name CmdImpressão
Caption Imprimir
Label1 Name Label1
Caption Dia/Mês
Label2 Name Label2
Caption Hora
Label3 Name Label3
Caption Hora
Label4 Name Label4
Caption Anotações
Label5 Name Label5
Caption Anotação
A Tabela
Crie um planilha que servirá de tabela para armazenar os dados diários de sua agenda.
Está tabela terá 367 linhas que serão os dias do ano e 25 colunas que serão as horas do dia em que serão anotados os afazeres. Como os campos da tabela são fixos 367 linhas por 24 colunas, utilizaremos as funções internas do Excel para trabalhar os dados com a mesma eficiência.
A Agenda
Crie uma planilha para que você possa ter suas informações diárias em mãos através de um formulário, onde você poderá imprimi-la e levar com você para obde você quiser. Nem sempre as informações somente virtuais são necessárias, tem ocasiões que necessitamos de um relatório para trabalharmos.
O Programa Agenda
Como funcionará o Programa Agenda:
Com o formulário ativado você deverá digitar um dia do ano de 2011 no BoxDia e automaticamente o sistema responderá fazendo uma varreadura na tabela "datas" para encontrar o dia digitado e preencherá o ComboHora com a 1ª Hora do dia, no caso 1:00, e o BoxResumo com as anotações horárias. Para digitar a tarefa ou afazer de uma determinada hora basta preencher o BoxAnotação e clicar no botão Incluir/Alterar.
Codificação do Programa Agenda
Inclua o seguinte código no procedimento UserForm_Activate( ) do formulário:
Private Sub UserForm_Activate()
Dim Cont
Me.ComboHora.Clear
For Cont = 1 To 24
Me.ComboHora.AddItem Format(Cont & ":00", "h:mm")
Next
Me.BoxDia = Format(Date, "dd/mm")
End Sub
Como uma agenda diária serve para anotações de seus afazeres em determinadas horas,
precisamos então de um objeto em que possamos selecionar determinada hora. Esse objeto em nosso aplicativo é o ComboHora.
Para se preencher um ComboBox existem duas maneiras:
1º Utilizando a propriedade RowSource do ComboBox, mencionado o intervalo de células que se deseja preencher o combo;
2º Preenchendo o ComboBox em tempo de execução, ou seja, preencher o ComboBox toda vez que o Userform for carregado.
Para se preencher um ComboBox em tempo de execução devemos utilizar a propriedade AddItem
Ex.: ComboExemplo.AddItem "Laranja"
ComboExemplo.AddItem "Banana"
No exemplo acima teremos um ComboBox com uma lista preenchida com os itens Laranja e Banana.
No nosso programa precisaremos preencher uma Combo com o intervalo de horas 1:00 e 24:00.Poderíamos preencher essa lista um a um como no exemplo anterior, mas é nesta hora que a lógica de programação toma conta. utilizaremos a instrução For... Next... , que significa percorrer um certo intervalo, e em cima deste intervalo poderemos ir preenchendo o ComboBox.
Private Sub boxdia_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Me.BoxDia = "" Then
Else
If IsDate(Me.BoxDia) Then
Me.ComboHora.ListIndex = -1
Me.BoxDia = Format(Me.BoxDia, "dd/mm")
Me.ComboHora.ListIndex = 0
Else
MsgBox "Data inválida...", vbCritical, "Minhas tarefas e lembretes.."
Cancel = True
End If
End If
End Sub
Detalhamento do código no procedimento boxdia_Exit( ) do formulário:
Como o BoxDia é a principal interface do aplicativo, é importantíssimo que mesmo seja preenchido corretamente para o perfeito funcionamento do aplicativo. Para que isso ocorra utilizamos uma função interna no Excel chamada IsDate. A função IsDate tem como objetivo checar se no objeto TextBox foi digitada uma data válida. Se sim o BoxDia é validado, senão o cursor permanecerá no TextBox até a correta digitação. Isto é feito graças ao ByVal da evento Exit. onde Cancel = true permi-
te que só se siga adiante se a informação for correta.
Outra Função utilizada é a Format, que permite deixar o TextBox do jeito que se quer. No código acima no BoxDia deve ser digitado uma data. Quando esta data for validada o a função Format transforma esta data em dia e mês já que o ano não é necessário ano pois a agenda é do ano de 2011.
No caso do BoxDia se for digitado 01/01/2011 a função Format retornará o BoxDia em 01/01.
Inclua o seguinte código no procedimento ComboHora_Click( ) do formulário:
Dê dois cliques sobre o ComboHora e o evento ComboHora_Click( ) é ativado. Dentro do evento digite o seguinte código:
Private Sub combohora_Click()
Me.PesquisarData
End Sub
Detalhamento do código no procedimento ComboHora_Click( ) do formulário:
Dentro do evento digitamos a palavra reservada "Me", que tem como função substituir o nome do formulário. Se digitarmos "FrmAgenda.PesquisarData" também está correto, e PesquisarData simplesmente também, porém o ideal é que se digite o endereço onde o código está alocado para que o sistema saiba qual código você está se referindo, pois pode ocorrer de ter dois códigos com o mesmo nome em módulos de programas diferentes, o que é permitido.
Já o termo "PesquisarData" é um código de programação que você verá abaixo. Com isso você acaba de aprender que podemos chamar um código de programação dentro de outro código, basta referenciar corretamente. Qual é a vantagem de se chamar um código dentro de outro código ?
Simples, para que um código não se torne muito longo.
Inclua o seguinte código no procedimento PesquisarData( ) dentro do módulo do formulário:
Sub PesquisarData()
Dim Célula As Excel.Range
Dim StrData, i, nLinha, Cont
i = 1
Me.BoxAnotação = ""
Me.BoxResumo = ""
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
Me.BoxAnotação = Plan2.Cells(i, Me.ComboHora.ListIndex + 2)
For Cont = 1 To 24
Me.BoxResumo = Me.BoxResumo & Chr(10) & Plan2.Cells(1, Cont + 1) & _
":00 - " & Plan2.Cells(i, Cont + 1)
Next
Exit For
End If
Next
End Sub
Detalhamento do código PesquisarData:
Com a planilha "datas" criada devemos primeiramente saber que quando folheamos uma agenda a principal parâmetro é a data. A Data é a base de toda consulta em nossa agenda. Aqui no nosso programa também, as datas são o centro de todas as atenções, e em cima disto vamos selecionar todas as células que fazem parte das datas de nossa agenda, no nosso caso é o intervalo compreendido "A2:A367" e clicando sobre a caixa de nomes vamos renomear este intervalo para "nDatas".
Como o Código PesquisarData funciona:
O sistema irá percorrer todo intervalo nDatas que você nomeou e localizando a data que você digitar no BoxDia irá automaticamente preencher o BoxAnotação com a anotação da 1ª hora, e irá preencher o BoxResumo com todas anotações do dia em ordem de hora.
Utilizamos a instrução For Each in para percorrer todo intervalo nDatas para descobrir qual célula tem a data igual ao BoxDia.
Inclua o seguinte código no procedimento CmdIncluir_Click( ) do formulário:
Private Sub CmdIncluir_Click()
Me.Incluir_Alterar
Me.PesquisarData
End Sub
Detalhamento do código no procedimento ComboHora_Click( ) do formulário:
Como no ComboHora dentro o procedimento CndIncluir_Click( ) foi digitado o nome de outro procedimento, o Incluir_alterar. A Função deste botão é de Incluir uma nova anotação ou alterar alguma anotação existente.
Criação do procedimento incluir_Alterar:
Sub Incluir_Alterar()
Dim Célula As Excel.Range
Dim StrData, i, nLinha
i = 1
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
Plan2.Cells(i, Me.ComboHora.ListIndex + 2) = Me.BoxAnotação
Exit For
End If
Next
End Sub
Neste procedimento utilizamos praticamente a mesma rotina do procedimento PesquisarData, pois já que a tabela é fixa (366 linhas x 24 colunas ) a única função deste procedimento é localizar um dia e alterar a anotação existente ou incluir uma anotação caso a célula esteja vazia.
Basicamente fica fácil demonstrar que com poucas linhas de comando e poucos objetos pode-se fazer um pequeno programa e muito eficiente.
Inclua o seguinte código no procedimento CmdImpressão_Click( ) do formulário:
Private Sub CmdImpressão_Click()
On Error GoTo aviso
Dim Célula As Excel.Range
Dim StrData, i, nLinha, Col
If Me.BoxDia = "" Then
MsgBox "Digite um dia para impressão", vbInformation, "Agenda"
Else
AGENDA.Range("A1") = Day(Me.BoxDia)
AGENDA.Range("B2") = UCase(Format(Me.BoxDia, "MMMM"))
AGENDA.Range("D2") = UCase(Dia_Semana(Me.BoxDia))
i = 1
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
For Col = 1 To 24
AGENDA.Range("B" & Col + 4) = Plan2.Cells(i, Col + 1)
Next Col
Exit For
End If
Next
AGENDA.Copy
End If
Exit Sub
aviso:
If Err.Number = 18 Then
Else
MsgBox Err.Number & "-" & Err.Description
End If
End Sub
Detalhamento do código no procedimento CmdImpressão_Click( ) do formulário:
Como nos procedimentos Incluir_Alterar_Click( ) e PesquisarData utilizamos aqui a instrução For Each Next para percorrer a tabela de datas e encontrando a data digitada no BoxDia o sistema preencherá a planilha Agenda e fará uma cópia da mesma para que usuário possa vizualiza-la e se desejar até imprimir o relatório. Dentro do procedimento CmdImpressão_Click( ) incluímos uma novi-
dade: a função Dia_Semana.
Esta função examina o dia da semana (WeekDay) do BoxDia e converte para extenso.
Como Ativar um Suplemento ?
Quando se converte um arquivo ".xls" para suplemento ".xla" temos que ter algum meio de ativar o aplicativo, pois como já esclarecemos, um suplemento do Excel se torna invisível ao nossos olhos, apesar de estar ativado. Existem duas maneiras de faze-lo, ou criando um botão na barra de ferramentas ou um itém de menu na barra de menus. No aplicativo agenda vamos inserir um itém de menu para poder ativar-lo e podemos opera-lo.
Inserindo um Item de Menu
No Editor de VBA, no menu inserir escolha Módulo. Temos que criar dois códigos, um para criar um item de menu e outro para excluir este mesmo item, ou seja quando se ativa um suplemento o item de menu será criado e quando se desativa um suplemento exclui-se este item de menu.
Para se incluir um item de menu digite o seguinte procedimento no Módulo 1 que você acabou se inserir:
Sub CriarItemMenu()
Dim ctlMenuItem As CommandBarControl
Dim intCount As Integer
Dim cBut As CommandBarButton
Dim strBarName As String
Dim lngID As Long
Call ExcluirItemMenu
strBarName = QUAL_MENU
Do
Select Case intCount
Case 0
lngID = 846
Case 1
lngID = 3823
Case 2
lngID = 748
Case 3
lngID = 3
End Select
Set ctlMenuItem = Application.CommandBars(strBarName). _
FindControl(Id:=lngID, recursive:=True)
Loop Until (Not ctlMenuItem Is Nothing) Or intCount = 3
If Not ctlMenuItem Is Nothing Then
Set cBut = ctlMenuItem.Parent.Controls.Add(before:=ctlMenuItem.Index + 1, _
temporary:=True)
With cBut
.FaceId = 125
.Caption = TÍTULO_ITEM_MENU
.OnAction = ThisWorkbook.Name & MACRO_ITEM_MENU
.Tag = TAG_ITEM_MENU
End With
End If
End Sub
Para que um item de menu seja corretamente alocado em um menu é necessário que o código avalie o menu verificando se já não existe um item de menu com as mesmas características, para se evitar tal falha dentro do código CriarItemMenu ( ) inseri o código ExcluiItemMenu ( ), ou seja o sistema primeiro excluirá um item de menu chamado "Minha Agenda Pessoal" para depois inclui-lo.
Segue abaixo código do procedimento ExcluirItemMenu:
Sub ExcluirItemMenu()
Dim ctlMenu As CommandBarControl
Dim ctlMenuItem As CommandBarControl
Dim strBarName As String
strBarName = QUAL_MENU
Set ctlMenuItem = Application.CommandBars(strBarName). _
FindControl(Tag:=TAG_ITEM_MENU, recursive:=True)
If Not ctlMenuItem Is Nothing Then ctlMenuItem.Delete
End Sub
Com o código para criação do item de menu pronto, como fazer que o sistema o leia automaticamente ? simples, vamos utilizar o evento de pasta Workbook_Open( ), ou seja todos procedimentos digitados no Workbook_Open são reconhecidos toda vez que o suplemento é ativado.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Módulo1.ExcluirItemMenu
End Sub
Private Sub Workbook_Open()
Módulo1.CriarItemMenu
End Sub
Convertendo um Arquivo XLS em Suplemento(XLA)
Esta é a parte mais simples, converter um arquivo XLS em XLA. Basta ir no Menu Arquivo(F12)item de menu Salvar Como , e no DropDown Salvar Tipo Como escolha Suplemento do Microsoft Excel.
Você pode salvar seu suplemento em quanquer diretório, mas se você quizer que seu arquivo fique visivel em na caixa de dialogo padrão do office chamada "suplementos" salve seu arquivo no diretorio "Bibliote" localizado dentro o SubDiretório Office,. Microsoft Office em Arquivos de Programas.
Depois de salva seu 1ºsuplemento, basta ativar a caixa de dialogo "suplementos".
Abaixo coloco todo o codigo da nossa agenda.
Modulo 1
Public Const QUAL_MENU As String = "Worksheet Menu Bar"
Public Const TÍTULO_ITEM_MENU As String = "&Minha Agenda Pessoal"
Public Const MACRO_ITEM_MENU As String = "!ExibirFormulário"
Public Const TAG_ITEM_MENU As String = "AGENDA"
Sub CriarItemMenu()
Dim ctlMenuItem As CommandBarControl
Dim intCount As Integer
Dim cBut As CommandBarButton
Dim strBarName As String
Dim lngID As Long
Call ExcluirItemMenu
strBarName = QUAL_MENU
Do
Select Case intCount
Case 0
lngID = 846
Case 1
lngID = 3823
Case 2
lngID = 748
Case 3
lngID = 3
End Select
Set ctlMenuItem = Application.CommandBars(strBarName). _
FindControl(Id:=lngID, recursive:=True)
Loop Until (Not ctlMenuItem Is Nothing) Or intCount = 3
If Not ctlMenuItem Is Nothing Then
Set cBut = ctlMenuItem.Parent.Controls.Add(before:=ctlMenuItem.Index + 1, _
temporary:=True)
With cBut
.FaceId = 125
.Caption = TÍTULO_ITEM_MENU
.OnAction = ThisWorkbook.Name & MACRO_ITEM_MENU
.Tag = TAG_ITEM_MENU
End With
End If
End Sub
Sub ExcluirItemMenu()
Dim ctlMenu As CommandBarControl
Dim ctlMenuItem As CommandBarControl
Dim strBarName As String
strBarName = QUAL_MENU
Set ctlMenuItem = Application.CommandBars(strBarName). _
FindControl(Tag:=TAG_ITEM_MENU, recursive:=True)
If Not ctlMenuItem Is Nothing Then ctlMenuItem.Delete
End Sub
Sub ExibirFormulário()
FrmAgenda.Show
End Sub
No Formulário
Private Function Dia_Semana(nDia As Date)
If WeekDay(nDia) = 1 Then
Dia_Semana = "Domingo"
ElseIf WeekDay(nDia) = 2 Then
Dia_Semana = "Segunda"
ElseIf WeekDay(nDia) = 3 Then
Dia_Semana = "Terça"
ElseIf WeekDay(nDia) = 4 Then
Dia_Semana = "Quarta"
ElseIf WeekDay(nDia) = 5 Then
Dia_Semana = "Quinta"
ElseIf WeekDay(nDia) = 6 Then
Dia_Semana = "Sexta"
ElseIf WeekDay(nDia) = 7 Then
Dia_Semana = "Sábado"
Else
Dia_Semana = "Desconhecido"
End If
End Function
Private Sub CmdImpressão_Click()
On Error GoTo aviso
Dim Célula As Excel.Range
Dim StrData, i, nLinha, Col
If Me.BoxDia = "" Then
MsgBox "Digite um dia para impressão", vbInformation, "Agenda"
Else
AGENDA.Range("A1") = Day(Me.BoxDia)
AGENDA.Range("B2") = UCase(Format(Me.BoxDia, "MMMM"))
AGENDA.Range("D2") = UCase(Dia_Semana(Me.BoxDia))
i = 1
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
For Col = 1 To 24
AGENDA.Range("B" & Col + 4) = Plan2.Cells(i, Col + 1)
Next Col
Exit For
End If
Next
AGENDA.Copy
End If
Exit Sub
aviso:
If Err.Number = 18 Then
Else
MsgBox Err.Number & "-" & Err.Description
End If
End Sub
Private Sub CmdIncluir_Click()
Me.Incluir_Alterar
Me.PesquisarData
End Sub
Private Sub CmdSair_Click()
End
End Sub
Private Sub combohora_Click()
Me.PesquisarData
End Sub
Private Sub boxdia_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Me.BoxDia = "" Then
Else
If IsDate(Me.BoxDia) Then
Me.ComboHora.ListIndex = -1
Me.BoxDia = Format(Me.BoxDia, "dd/mm")
Me.ComboHora.ListIndex = 0
Else
MsgBox "Data inválida...", vbCritical, "Minhas tarefas e lembretes.."
Cancel = True
End If
End If
End Sub
Private Sub UserForm_Activate()
Dim Cont
Me.ComboHora.Clear
For Cont = 1 To 24
Me.ComboHora.AddItem Format(Cont & ":00", "h:mm")
Next
Me.BoxDia = Format(Date, "dd/mm")
End Sub
Sub PesquisarData()
Dim Célula As Excel.Range
Dim StrData, i, nLinha, Cont
i = 1
Me.BoxAnotação = ""
Me.BoxResumo = ""
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
Me.BoxAnotação = Plan2.Cells(i, Me.ComboHora.ListIndex + 2)
For Cont = 1 To 24
Me.BoxResumo = Me.BoxResumo & Chr(10) & Plan2.Cells(1, Cont + 1) & _
":00 - " & Plan2.Cells(i, Cont + 1)
Next
Exit For
End If
Next
End Sub
Sub Incluir_Alterar()
Dim Célula As Excel.Range
Dim StrData, i, nLinha
i = 1
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
Plan2.Cells(i, Me.ComboHora.ListIndex + 2) = Me.BoxAnotação
Exit For
End If
Next
End Sub
E em Esta_Pasta_de_Trabalho
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Módulo1.ExcluirItemMenu
End Sub
Private Sub Workbook_Open()
Módulo1.CriarItemMenu
End Sub
Os suplementos são programas que adicionam comandos e recursos opcionais ao Microsoft Excel.
Antes de usar um suplemento, você precisa instalá-lo no computador e, em seguida, carregá-lo
no Microsoft Excel. Por padrão, os suplementos (arquivos *.xla) são instalados na pasta Biblioteca
da pasta do Microsoft Excel. O carregamento de um suplemento disponibiliza o recurso no
Microsoft Excel e adiciona todos os comandos associados aos menus adequados. Os programas
suplementares listados na tabela a seguir são instalados, por padrão, na pasta Biblioteca, ou em
uma de suas subpastas, na pasta do Microsoft Excel. Se você não conseguir localizar determinado
suplemento no disco rígido ou em uma unidade da rede, poderá instalá-lo. Após instalar um
suplemento, será necessário usar o comando Suplementos (menu Ferramentas) para carregá-lo no
Microsoft Excel.
A partir dessa breve explicação vamos desenvolver nossa aplicação uma Agenda simples, porem muito funcional.
As Ferramentas necessárias
Para a criação de nossa Agenda de Tarefas precisaremos de um formulário para a inclusão e
consulta das tarefas agendadas , de uma planilha que servirá para armazenar as informações e ou-
tra planilha que servirá como relatório caso se deseje imprimir as anotações do dia.
O Formulário
Crie o formulário Agenda utilizando as especificações que fazem parte da Tabela a seguir:
Objeto Propriedade Ajuste
Formulário Name frmAgenda
Caption Anote Seus Afazeres e Lembretes para o ano de 2011
TextBox1 Name BoxDia
Font Takoma 10
TextAlign 2 - Center
TextBox2 Name BoxAnotações
Font Takoma 8
TextAlign 1 - Left
EnterKeyBehavior True
MultiLine True
TextBox3 Name BoxResumo
Font Takoma 8
TextAlign 1 - Left
EnterKeyBehavior True
MultiLine True
ScroollBars 3 - FmScrollBarsBoth
CommandButton1 Name CmdSair
Caption Incluir/Alterar
CommandButton2 Name CmdImpressão
Caption Imprimir
Label1 Name Label1
Caption Dia/Mês
Label2 Name Label2
Caption Hora
Label3 Name Label3
Caption Hora
Label4 Name Label4
Caption Anotações
Label5 Name Label5
Caption Anotação
A Tabela
Crie um planilha que servirá de tabela para armazenar os dados diários de sua agenda.
Está tabela terá 367 linhas que serão os dias do ano e 25 colunas que serão as horas do dia em que serão anotados os afazeres. Como os campos da tabela são fixos 367 linhas por 24 colunas, utilizaremos as funções internas do Excel para trabalhar os dados com a mesma eficiência.
A Agenda
Crie uma planilha para que você possa ter suas informações diárias em mãos através de um formulário, onde você poderá imprimi-la e levar com você para obde você quiser. Nem sempre as informações somente virtuais são necessárias, tem ocasiões que necessitamos de um relatório para trabalharmos.
O Programa Agenda
Como funcionará o Programa Agenda:
Com o formulário ativado você deverá digitar um dia do ano de 2011 no BoxDia e automaticamente o sistema responderá fazendo uma varreadura na tabela "datas" para encontrar o dia digitado e preencherá o ComboHora com a 1ª Hora do dia, no caso 1:00, e o BoxResumo com as anotações horárias. Para digitar a tarefa ou afazer de uma determinada hora basta preencher o BoxAnotação e clicar no botão Incluir/Alterar.
Codificação do Programa Agenda
Inclua o seguinte código no procedimento UserForm_Activate( ) do formulário:
Private Sub UserForm_Activate()
Dim Cont
Me.ComboHora.Clear
For Cont = 1 To 24
Me.ComboHora.AddItem Format(Cont & ":00", "h:mm")
Next
Me.BoxDia = Format(Date, "dd/mm")
End Sub
Como uma agenda diária serve para anotações de seus afazeres em determinadas horas,
precisamos então de um objeto em que possamos selecionar determinada hora. Esse objeto em nosso aplicativo é o ComboHora.
Para se preencher um ComboBox existem duas maneiras:
1º Utilizando a propriedade RowSource do ComboBox, mencionado o intervalo de células que se deseja preencher o combo;
2º Preenchendo o ComboBox em tempo de execução, ou seja, preencher o ComboBox toda vez que o Userform for carregado.
Para se preencher um ComboBox em tempo de execução devemos utilizar a propriedade AddItem
Ex.: ComboExemplo.AddItem "Laranja"
ComboExemplo.AddItem "Banana"
No exemplo acima teremos um ComboBox com uma lista preenchida com os itens Laranja e Banana.
No nosso programa precisaremos preencher uma Combo com o intervalo de horas 1:00 e 24:00.Poderíamos preencher essa lista um a um como no exemplo anterior, mas é nesta hora que a lógica de programação toma conta. utilizaremos a instrução For... Next... , que significa percorrer um certo intervalo, e em cima deste intervalo poderemos ir preenchendo o ComboBox.
Private Sub boxdia_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Me.BoxDia = "" Then
Else
If IsDate(Me.BoxDia) Then
Me.ComboHora.ListIndex = -1
Me.BoxDia = Format(Me.BoxDia, "dd/mm")
Me.ComboHora.ListIndex = 0
Else
MsgBox "Data inválida...", vbCritical, "Minhas tarefas e lembretes.."
Cancel = True
End If
End If
End Sub
Detalhamento do código no procedimento boxdia_Exit( ) do formulário:
Como o BoxDia é a principal interface do aplicativo, é importantíssimo que mesmo seja preenchido corretamente para o perfeito funcionamento do aplicativo. Para que isso ocorra utilizamos uma função interna no Excel chamada IsDate. A função IsDate tem como objetivo checar se no objeto TextBox foi digitada uma data válida. Se sim o BoxDia é validado, senão o cursor permanecerá no TextBox até a correta digitação. Isto é feito graças ao ByVal da evento Exit. onde Cancel = true permi-
te que só se siga adiante se a informação for correta.
Outra Função utilizada é a Format, que permite deixar o TextBox do jeito que se quer. No código acima no BoxDia deve ser digitado uma data. Quando esta data for validada o a função Format transforma esta data em dia e mês já que o ano não é necessário ano pois a agenda é do ano de 2011.
No caso do BoxDia se for digitado 01/01/2011 a função Format retornará o BoxDia em 01/01.
Inclua o seguinte código no procedimento ComboHora_Click( ) do formulário:
Dê dois cliques sobre o ComboHora e o evento ComboHora_Click( ) é ativado. Dentro do evento digite o seguinte código:
Private Sub combohora_Click()
Me.PesquisarData
End Sub
Detalhamento do código no procedimento ComboHora_Click( ) do formulário:
Dentro do evento digitamos a palavra reservada "Me", que tem como função substituir o nome do formulário. Se digitarmos "FrmAgenda.PesquisarData" também está correto, e PesquisarData simplesmente também, porém o ideal é que se digite o endereço onde o código está alocado para que o sistema saiba qual código você está se referindo, pois pode ocorrer de ter dois códigos com o mesmo nome em módulos de programas diferentes, o que é permitido.
Já o termo "PesquisarData" é um código de programação que você verá abaixo. Com isso você acaba de aprender que podemos chamar um código de programação dentro de outro código, basta referenciar corretamente. Qual é a vantagem de se chamar um código dentro de outro código ?
Simples, para que um código não se torne muito longo.
Inclua o seguinte código no procedimento PesquisarData( ) dentro do módulo do formulário:
Sub PesquisarData()
Dim Célula As Excel.Range
Dim StrData, i, nLinha, Cont
i = 1
Me.BoxAnotação = ""
Me.BoxResumo = ""
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
Me.BoxAnotação = Plan2.Cells(i, Me.ComboHora.ListIndex + 2)
For Cont = 1 To 24
Me.BoxResumo = Me.BoxResumo & Chr(10) & Plan2.Cells(1, Cont + 1) & _
":00 - " & Plan2.Cells(i, Cont + 1)
Next
Exit For
End If
Next
End Sub
Detalhamento do código PesquisarData:
Com a planilha "datas" criada devemos primeiramente saber que quando folheamos uma agenda a principal parâmetro é a data. A Data é a base de toda consulta em nossa agenda. Aqui no nosso programa também, as datas são o centro de todas as atenções, e em cima disto vamos selecionar todas as células que fazem parte das datas de nossa agenda, no nosso caso é o intervalo compreendido "A2:A367" e clicando sobre a caixa de nomes vamos renomear este intervalo para "nDatas".
Como o Código PesquisarData funciona:
O sistema irá percorrer todo intervalo nDatas que você nomeou e localizando a data que você digitar no BoxDia irá automaticamente preencher o BoxAnotação com a anotação da 1ª hora, e irá preencher o BoxResumo com todas anotações do dia em ordem de hora.
Utilizamos a instrução For Each in para percorrer todo intervalo nDatas para descobrir qual célula tem a data igual ao BoxDia.
Inclua o seguinte código no procedimento CmdIncluir_Click( ) do formulário:
Private Sub CmdIncluir_Click()
Me.Incluir_Alterar
Me.PesquisarData
End Sub
Detalhamento do código no procedimento ComboHora_Click( ) do formulário:
Como no ComboHora dentro o procedimento CndIncluir_Click( ) foi digitado o nome de outro procedimento, o Incluir_alterar. A Função deste botão é de Incluir uma nova anotação ou alterar alguma anotação existente.
Criação do procedimento incluir_Alterar:
Sub Incluir_Alterar()
Dim Célula As Excel.Range
Dim StrData, i, nLinha
i = 1
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
Plan2.Cells(i, Me.ComboHora.ListIndex + 2) = Me.BoxAnotação
Exit For
End If
Next
End Sub
Neste procedimento utilizamos praticamente a mesma rotina do procedimento PesquisarData, pois já que a tabela é fixa (366 linhas x 24 colunas ) a única função deste procedimento é localizar um dia e alterar a anotação existente ou incluir uma anotação caso a célula esteja vazia.
Basicamente fica fácil demonstrar que com poucas linhas de comando e poucos objetos pode-se fazer um pequeno programa e muito eficiente.
Inclua o seguinte código no procedimento CmdImpressão_Click( ) do formulário:
Private Sub CmdImpressão_Click()
On Error GoTo aviso
Dim Célula As Excel.Range
Dim StrData, i, nLinha, Col
If Me.BoxDia = "" Then
MsgBox "Digite um dia para impressão", vbInformation, "Agenda"
Else
AGENDA.Range("A1") = Day(Me.BoxDia)
AGENDA.Range("B2") = UCase(Format(Me.BoxDia, "MMMM"))
AGENDA.Range("D2") = UCase(Dia_Semana(Me.BoxDia))
i = 1
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
For Col = 1 To 24
AGENDA.Range("B" & Col + 4) = Plan2.Cells(i, Col + 1)
Next Col
Exit For
End If
Next
AGENDA.Copy
End If
Exit Sub
aviso:
If Err.Number = 18 Then
Else
MsgBox Err.Number & "-" & Err.Description
End If
End Sub
Detalhamento do código no procedimento CmdImpressão_Click( ) do formulário:
Como nos procedimentos Incluir_Alterar_Click( ) e PesquisarData utilizamos aqui a instrução For Each Next para percorrer a tabela de datas e encontrando a data digitada no BoxDia o sistema preencherá a planilha Agenda e fará uma cópia da mesma para que usuário possa vizualiza-la e se desejar até imprimir o relatório. Dentro do procedimento CmdImpressão_Click( ) incluímos uma novi-
dade: a função Dia_Semana.
Esta função examina o dia da semana (WeekDay) do BoxDia e converte para extenso.
Como Ativar um Suplemento ?
Quando se converte um arquivo ".xls" para suplemento ".xla" temos que ter algum meio de ativar o aplicativo, pois como já esclarecemos, um suplemento do Excel se torna invisível ao nossos olhos, apesar de estar ativado. Existem duas maneiras de faze-lo, ou criando um botão na barra de ferramentas ou um itém de menu na barra de menus. No aplicativo agenda vamos inserir um itém de menu para poder ativar-lo e podemos opera-lo.
Inserindo um Item de Menu
No Editor de VBA, no menu inserir escolha Módulo. Temos que criar dois códigos, um para criar um item de menu e outro para excluir este mesmo item, ou seja quando se ativa um suplemento o item de menu será criado e quando se desativa um suplemento exclui-se este item de menu.
Para se incluir um item de menu digite o seguinte procedimento no Módulo 1 que você acabou se inserir:
Sub CriarItemMenu()
Dim ctlMenuItem As CommandBarControl
Dim intCount As Integer
Dim cBut As CommandBarButton
Dim strBarName As String
Dim lngID As Long
Call ExcluirItemMenu
strBarName = QUAL_MENU
Do
Select Case intCount
Case 0
lngID = 846
Case 1
lngID = 3823
Case 2
lngID = 748
Case 3
lngID = 3
End Select
Set ctlMenuItem = Application.CommandBars(strBarName). _
FindControl(Id:=lngID, recursive:=True)
Loop Until (Not ctlMenuItem Is Nothing) Or intCount = 3
If Not ctlMenuItem Is Nothing Then
Set cBut = ctlMenuItem.Parent.Controls.Add(before:=ctlMenuItem.Index + 1, _
temporary:=True)
With cBut
.FaceId = 125
.Caption = TÍTULO_ITEM_MENU
.OnAction = ThisWorkbook.Name & MACRO_ITEM_MENU
.Tag = TAG_ITEM_MENU
End With
End If
End Sub
Para que um item de menu seja corretamente alocado em um menu é necessário que o código avalie o menu verificando se já não existe um item de menu com as mesmas características, para se evitar tal falha dentro do código CriarItemMenu ( ) inseri o código ExcluiItemMenu ( ), ou seja o sistema primeiro excluirá um item de menu chamado "Minha Agenda Pessoal" para depois inclui-lo.
Segue abaixo código do procedimento ExcluirItemMenu:
Sub ExcluirItemMenu()
Dim ctlMenu As CommandBarControl
Dim ctlMenuItem As CommandBarControl
Dim strBarName As String
strBarName = QUAL_MENU
Set ctlMenuItem = Application.CommandBars(strBarName). _
FindControl(Tag:=TAG_ITEM_MENU, recursive:=True)
If Not ctlMenuItem Is Nothing Then ctlMenuItem.Delete
End Sub
Com o código para criação do item de menu pronto, como fazer que o sistema o leia automaticamente ? simples, vamos utilizar o evento de pasta Workbook_Open( ), ou seja todos procedimentos digitados no Workbook_Open são reconhecidos toda vez que o suplemento é ativado.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Módulo1.ExcluirItemMenu
End Sub
Private Sub Workbook_Open()
Módulo1.CriarItemMenu
End Sub
Convertendo um Arquivo XLS em Suplemento(XLA)
Esta é a parte mais simples, converter um arquivo XLS em XLA. Basta ir no Menu Arquivo(F12)item de menu Salvar Como , e no DropDown Salvar Tipo Como escolha Suplemento do Microsoft Excel.
Você pode salvar seu suplemento em quanquer diretório, mas se você quizer que seu arquivo fique visivel em na caixa de dialogo padrão do office chamada "suplementos" salve seu arquivo no diretorio "Bibliote" localizado dentro o SubDiretório Office,. Microsoft Office em Arquivos de Programas.
Depois de salva seu 1ºsuplemento, basta ativar a caixa de dialogo "suplementos".
Abaixo coloco todo o codigo da nossa agenda.
Modulo 1
Public Const QUAL_MENU As String = "Worksheet Menu Bar"
Public Const TÍTULO_ITEM_MENU As String = "&Minha Agenda Pessoal"
Public Const MACRO_ITEM_MENU As String = "!ExibirFormulário"
Public Const TAG_ITEM_MENU As String = "AGENDA"
Sub CriarItemMenu()
Dim ctlMenuItem As CommandBarControl
Dim intCount As Integer
Dim cBut As CommandBarButton
Dim strBarName As String
Dim lngID As Long
Call ExcluirItemMenu
strBarName = QUAL_MENU
Do
Select Case intCount
Case 0
lngID = 846
Case 1
lngID = 3823
Case 2
lngID = 748
Case 3
lngID = 3
End Select
Set ctlMenuItem = Application.CommandBars(strBarName). _
FindControl(Id:=lngID, recursive:=True)
Loop Until (Not ctlMenuItem Is Nothing) Or intCount = 3
If Not ctlMenuItem Is Nothing Then
Set cBut = ctlMenuItem.Parent.Controls.Add(before:=ctlMenuItem.Index + 1, _
temporary:=True)
With cBut
.FaceId = 125
.Caption = TÍTULO_ITEM_MENU
.OnAction = ThisWorkbook.Name & MACRO_ITEM_MENU
.Tag = TAG_ITEM_MENU
End With
End If
End Sub
Sub ExcluirItemMenu()
Dim ctlMenu As CommandBarControl
Dim ctlMenuItem As CommandBarControl
Dim strBarName As String
strBarName = QUAL_MENU
Set ctlMenuItem = Application.CommandBars(strBarName). _
FindControl(Tag:=TAG_ITEM_MENU, recursive:=True)
If Not ctlMenuItem Is Nothing Then ctlMenuItem.Delete
End Sub
Sub ExibirFormulário()
FrmAgenda.Show
End Sub
No Formulário
Private Function Dia_Semana(nDia As Date)
If WeekDay(nDia) = 1 Then
Dia_Semana = "Domingo"
ElseIf WeekDay(nDia) = 2 Then
Dia_Semana = "Segunda"
ElseIf WeekDay(nDia) = 3 Then
Dia_Semana = "Terça"
ElseIf WeekDay(nDia) = 4 Then
Dia_Semana = "Quarta"
ElseIf WeekDay(nDia) = 5 Then
Dia_Semana = "Quinta"
ElseIf WeekDay(nDia) = 6 Then
Dia_Semana = "Sexta"
ElseIf WeekDay(nDia) = 7 Then
Dia_Semana = "Sábado"
Else
Dia_Semana = "Desconhecido"
End If
End Function
Private Sub CmdImpressão_Click()
On Error GoTo aviso
Dim Célula As Excel.Range
Dim StrData, i, nLinha, Col
If Me.BoxDia = "" Then
MsgBox "Digite um dia para impressão", vbInformation, "Agenda"
Else
AGENDA.Range("A1") = Day(Me.BoxDia)
AGENDA.Range("B2") = UCase(Format(Me.BoxDia, "MMMM"))
AGENDA.Range("D2") = UCase(Dia_Semana(Me.BoxDia))
i = 1
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
For Col = 1 To 24
AGENDA.Range("B" & Col + 4) = Plan2.Cells(i, Col + 1)
Next Col
Exit For
End If
Next
AGENDA.Copy
End If
Exit Sub
aviso:
If Err.Number = 18 Then
Else
MsgBox Err.Number & "-" & Err.Description
End If
End Sub
Private Sub CmdIncluir_Click()
Me.Incluir_Alterar
Me.PesquisarData
End Sub
Private Sub CmdSair_Click()
End
End Sub
Private Sub combohora_Click()
Me.PesquisarData
End Sub
Private Sub boxdia_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Me.BoxDia = "" Then
Else
If IsDate(Me.BoxDia) Then
Me.ComboHora.ListIndex = -1
Me.BoxDia = Format(Me.BoxDia, "dd/mm")
Me.ComboHora.ListIndex = 0
Else
MsgBox "Data inválida...", vbCritical, "Minhas tarefas e lembretes.."
Cancel = True
End If
End If
End Sub
Private Sub UserForm_Activate()
Dim Cont
Me.ComboHora.Clear
For Cont = 1 To 24
Me.ComboHora.AddItem Format(Cont & ":00", "h:mm")
Next
Me.BoxDia = Format(Date, "dd/mm")
End Sub
Sub PesquisarData()
Dim Célula As Excel.Range
Dim StrData, i, nLinha, Cont
i = 1
Me.BoxAnotação = ""
Me.BoxResumo = ""
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
Me.BoxAnotação = Plan2.Cells(i, Me.ComboHora.ListIndex + 2)
For Cont = 1 To 24
Me.BoxResumo = Me.BoxResumo & Chr(10) & Plan2.Cells(1, Cont + 1) & _
":00 - " & Plan2.Cells(i, Cont + 1)
Next
Exit For
End If
Next
End Sub
Sub Incluir_Alterar()
Dim Célula As Excel.Range
Dim StrData, i, nLinha
i = 1
For Each Célula In ThisWorkbook.Sheets("datas").Range("nDatas").Cells
StrData = Célula.Value
i = i + 1
If CDate(Me.BoxDia) = CDate(StrData) Then
nLinha = i
Plan2.Cells(i, Me.ComboHora.ListIndex + 2) = Me.BoxAnotação
Exit For
End If
Next
End Sub
E em Esta_Pasta_de_Trabalho
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Módulo1.ExcluirItemMenu
End Sub
Private Sub Workbook_Open()
Módulo1.CriarItemMenu
End Sub
Banco de dados com Excel
O primeiro passo é criar a conexão, segue abaixo.
Sub AbrindoUmaTabela()
Dim MeuBD As Database
Dim MinhaTabela As Recordset
Set MeuBD = OpenDatabase(ThisWorkbook.Path & "/" & ThisWorkbook.Name, False, False, "Excel 8.0")
Set MinhaTabela = MeuBD.OpenRecordset("$")
MsgBox MinhaTabela(0)
MeuBD.Close
End Sub
após isso feito, você pode utilizar esta conexão para para criar filtros como o Select abaixo.
Sub Gol()'nome da macro
Dim MeuBD As Database
Dim MinhaTabela As Recordset
Set MeuBD = OpenDatabase(ThisWorkbook.Path & "/" & ThisWorkbook.Name, False, False, "Excel 8.0")
Set MinhaTabela = MeuBD.OpenRecordset("SELECT numero,nome, gol FROM [jogadores$] ORDER BY gol DESC;")'fazendo select na planilha jogadores e colocando em ordem decrescente
'Plan6.Cells.ClearContents
Plan6.Range("a2").CopyFromRecordset MinhaTabela
MeuBD.Close
End Sub
Sub AbrindoUmaTabela()
Dim MeuBD As Database
Dim MinhaTabela As Recordset
Set MeuBD = OpenDatabase(ThisWorkbook.Path & "/" & ThisWorkbook.Name, False, False, "Excel 8.0")
Set MinhaTabela = MeuBD.OpenRecordset("$")
MsgBox MinhaTabela(0)
MeuBD.Close
End Sub
após isso feito, você pode utilizar esta conexão para para criar filtros como o Select abaixo.
Sub Gol()'nome da macro
Dim MeuBD As Database
Dim MinhaTabela As Recordset
Set MeuBD = OpenDatabase(ThisWorkbook.Path & "/" & ThisWorkbook.Name, False, False, "Excel 8.0")
Set MinhaTabela = MeuBD.OpenRecordset("SELECT numero,nome, gol FROM [jogadores$] ORDER BY gol DESC;")'fazendo select na planilha jogadores e colocando em ordem decrescente
'Plan6.Cells.ClearContents
Plan6.Range("a2").CopyFromRecordset MinhaTabela
MeuBD.Close
End Sub
Planilha com data de expiração
Já pensou algumas vezes passar sua planilha para um amigo, colega ou terceiros e não saber como estes irão usa-las, ou ainda pior se apropriarem de suas ideias? para isso coloco abaixo um código onde sua planilha irá expirar no momento que o usuário fechar a mesma.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim dtexp As Date
'Escolha a data que deverá expirar
dtexp = ("29/04/2011") 'inibir aqui'
If Date >= #1/11/2010# Then 'ativar esta'
If Date >= dtexp Then 'inibir aqui'
ThisWorkbook.Saved = True
'Se quiser enviar mensagem apenas retire a aspa simples da linha de baixo ou personalize
'MsgBox "Este arquivo está expirado, se auto-excluirá!"
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
End If
End If
End Sub
**Obs. não irá nem para lixeira
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim dtexp As Date
'Escolha a data que deverá expirar
dtexp = ("29/04/2011") 'inibir aqui'
If Date >= #1/11/2010# Then 'ativar esta'
If Date >= dtexp Then 'inibir aqui'
ThisWorkbook.Saved = True
'Se quiser enviar mensagem apenas retire a aspa simples da linha de baixo ou personalize
'MsgBox "Este arquivo está expirado, se auto-excluirá!"
ThisWorkbook.ChangeFileAccess xlReadOnly
Kill ThisWorkbook.FullName
End If
End If
End Sub
**Obs. não irá nem para lixeira
Inserir senha de acesso a planilha
Lembrando que para funcionar perfeitamente devemos colocar em EstaPasta_de_Trabalho
Private Sub Workbook_Open()
senha
End Sub
e no modulo o codigo abaixo
Option Explicit
Sub travar()
Dim Plan As Worksheet
For Each Plan In Worksheets
'Verifica se não é a primeira
If Plan.Name <> "Tela" Then
Plan.Protect "123"
Plan.Visible = xlSheetVeryHidden
End If
Next
End Sub
Sub destravar()
Dim Plan As Worksheet
For Each Plan In Worksheets
'Verifica se não é a primeira
If Plan.Name <> "Tela" Then
Plan.Unprotect "123"
Plan.Visible = xlSheetVisible
End If
Next
End Sub
Sub senha()
Dim txtSenha As String
Dim txtLogin As String
'Em caso de erro, retornará sempre para este ponto
inicio:
txtLogin = InputBox("Informe o login")
txtSenha = InputBox("Informe a senha")
Sheets("Senhas").Select
Range("A2").Select
'Loop que realizará a pesquisa do login
Do While ActiveCell <> Empty
If ActiveCell = txtLogin Then
If ActiveCell.Offset(0, 1) = txtSenha Then
destravar
Exit Sub
Else
MsgBox "Senha incorreta!"
GoTo inicio
End If
End If
'Incremento
ActiveCell.Offset(1, 0).Activate
Loop
MsgBox "Login incorreto!"
GoTo inicio
End Sub
Crie uma planilha chamada Senhas e defina ali seu(s) usuario(s) senhas, a partir da celula A1 (user) e B1(senha)
Private Sub Workbook_Open()
senha
End Sub
e no modulo o codigo abaixo
Option Explicit
Sub travar()
Dim Plan As Worksheet
For Each Plan In Worksheets
'Verifica se não é a primeira
If Plan.Name <> "Tela" Then
Plan.Protect "123"
Plan.Visible = xlSheetVeryHidden
End If
Next
End Sub
Sub destravar()
Dim Plan As Worksheet
For Each Plan In Worksheets
'Verifica se não é a primeira
If Plan.Name <> "Tela" Then
Plan.Unprotect "123"
Plan.Visible = xlSheetVisible
End If
Next
End Sub
Sub senha()
Dim txtSenha As String
Dim txtLogin As String
'Em caso de erro, retornará sempre para este ponto
inicio:
txtLogin = InputBox("Informe o login")
txtSenha = InputBox("Informe a senha")
Sheets("Senhas").Select
Range("A2").Select
'Loop que realizará a pesquisa do login
Do While ActiveCell <> Empty
If ActiveCell = txtLogin Then
If ActiveCell.Offset(0, 1) = txtSenha Then
destravar
Exit Sub
Else
MsgBox "Senha incorreta!"
GoTo inicio
End If
End If
'Incremento
ActiveCell.Offset(1, 0).Activate
Loop
MsgBox "Login incorreto!"
GoTo inicio
End Sub
Crie uma planilha chamada Senhas e defina ali seu(s) usuario(s) senhas, a partir da celula A1 (user) e B1(senha)
Habilitar barra horizontal do Excel
Neste exemplo o mesmo botão habilita e desabilita a barra de rolagem horizontal do Excel.
Sub barraHorizontal()
ActiveWindow.DisplayHorizontalScrollBar = Not ActiveWindow.DisplayHorizontalScrollBar
End Sub
Sub barraHorizontal()
ActiveWindow.DisplayHorizontalScrollBar = Not ActiveWindow.DisplayHorizontalScrollBar
End Sub
Habilitar e desabilitar cabeçalhos de linhas e colunas
Neste exemplo o mesmo botão habilita e desabilita o cabeçalho de linhas e colunas
Sub cabecalhos()
ActiveWindow.DisplayHeadings = Not ActiveWindow.DisplayHeadings
End Sub
Sub cabecalhos()
ActiveWindow.DisplayHeadings = Not ActiveWindow.DisplayHeadings
End Sub
Desproteger qualquer planilha
Sub DesprotegerPlanilhaAtiva()
' desprotege qualquer planílha com senha
Dim i, i1, i2, i3, i4, i5, i6 As Integer, j As Integer, k As Integer, 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 "Planilha desprotegida com sucesso!!!"
Exit Sub
End If
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
End Sub
' desprotege qualquer planílha com senha
Dim i, i1, i2, i3, i4, i5, i6 As Integer, j As Integer, k As Integer, 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 "Planilha desprotegida com sucesso!!!"
Exit Sub
End If
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
End Sub
Dicas gerais vba
Clear = apaga tudo
ClearContents = apaga somente o conteúdo
ClearFormats = apaga formatação
ClearComments = apaga comentários
---
Obtendo valores de outras planilhas
Buscar endereço de outra planilha
- worksheets("Nome") ou sheets("nome")
ou índice sheets(1)
----
Offset(linha,coluna)
A seleção (cursor) é o ponto central
para baixo e para a direita, positivo
para cima e para a esquerda, negativo
----
Cell(linha,coluna)
----
Deslocamentos para os extremos
.end(xlUp) = CTRL + seta para cima
.end(xlDown) = CTRL + seta para baixo
.end(xlToRight) = CTRL + seta para direita
.end(xlToLeft) = CTRL + seta para esquerda
----
Formulário
código:
inputbox(prompt,[title],[value],[xpos],[ypos])
if - condição then (instruções se verdadeiras)
end if
(continua lendo o código de baixo)
----
target.address - endereço alvo
---------------------------
looping
do while - condição
instruções
loop
for valor inicial to - n. de vezes, incremento
instruções
next
for each elemento in grupo
instruções
next
'transformar primeira letra em maúscula
strConv(texto,cod)
-->cod = 1 maiúscula
= 2 minúscula
= 3 primeira letra maiúscula
row - retorna a linha
columns - retorna a coluna
range(selection,selection.end(xltoright)).select
range(selection,selection.end(xldown)).select
-----------------------------
looping
cont = cont + 1
total = total + 1
isNumeric(valor) rtorna verdadeiro se o valor for número
isString(valor) retorna verdadeiro se o valor for texto
isDate(valor) retorna verdadeiro se o valor for data
-----------------------------
Trabalhando com datas
dateadd(parte,qtde,data)
Novo looping
for valor inicial to condicao, step
next
private function nome (argumento as tipo, argumento as tipo) as tipo
instruções
-----------------------------
Nomes de campos
=DESLOC(Rascunho!$A$2;0;0;CONT.VALORES(Rascunho!$A$2:$A$300);1)
-----------------------------
PivotTable - Tabela Dinâmica
Opções/mostrar páginas do filtro de relatório
'Para gerar uma página para cada item do filtro
onerror goto error - tratamento de erro
pula o próximo código e vai pra a lilnha de erro
on error resume next = tratamento de erro
pula o próximo código e continua a ler os demais
ClearContents = apaga somente o conteúdo
ClearFormats = apaga formatação
ClearComments = apaga comentários
---
Obtendo valores de outras planilhas
Buscar endereço de outra planilha
- worksheets("Nome") ou sheets("nome")
ou índice sheets(1)
----
Offset(linha,coluna)
A seleção (cursor) é o ponto central
para baixo e para a direita, positivo
para cima e para a esquerda, negativo
----
Cell(linha,coluna)
----
Deslocamentos para os extremos
.end(xlUp) = CTRL + seta para cima
.end(xlDown) = CTRL + seta para baixo
.end(xlToRight) = CTRL + seta para direita
.end(xlToLeft) = CTRL + seta para esquerda
----
Formulário
código:
inputbox(prompt,[title],[value],[xpos],[ypos])
if - condição then (instruções se verdadeiras)
end if
(continua lendo o código de baixo)
----
target.address - endereço alvo
---------------------------
looping
do while - condição
instruções
loop
for valor inicial to - n. de vezes, incremento
instruções
next
for each elemento in grupo
instruções
next
'transformar primeira letra em maúscula
strConv(texto,cod)
-->cod = 1 maiúscula
= 2 minúscula
= 3 primeira letra maiúscula
row - retorna a linha
columns - retorna a coluna
range(selection,selection.end(xltoright)).select
range(selection,selection.end(xldown)).select
-----------------------------
looping
cont = cont + 1
total = total + 1
isNumeric(valor) rtorna verdadeiro se o valor for número
isString(valor) retorna verdadeiro se o valor for texto
isDate(valor) retorna verdadeiro se o valor for data
-----------------------------
Trabalhando com datas
dateadd(parte,qtde,data)
Novo looping
for valor inicial to condicao, step
next
private function nome (argumento as tipo, argumento as tipo) as tipo
instruções
-----------------------------
Nomes de campos
=DESLOC(Rascunho!$A$2;0;0;CONT.VALORES(Rascunho!$A$2:$A$300);1)
-----------------------------
PivotTable - Tabela Dinâmica
Opções/mostrar páginas do filtro de relatório
'Para gerar uma página para cada item do filtro
onerror goto error - tratamento de erro
pula o próximo código e vai pra a lilnha de erro
on error resume next = tratamento de erro
pula o próximo código e continua a ler os demais
Assinar:
Postagens (Atom)