MS Excel – Criando Menu com VBA

Podemos criar menus para a utilização dos nossos usuários focando

algumas especialidades nas nossas aplicações.

 

Através destas opções direcionamos ações específicas.

 

Sub Create_Menu()

' Define as variáveis.

Dim MyBar As CommandBar

Dim MyPopup As CommandBarPopup

Dim MyButton As CommandBarButton

 

' Deleta o menu anterior.

Delete_Menu

 

' Cria a Barra com um nome.

Set MyBar = CommandBars.Add(Name:="Grafico", Position:=msoBarFloating, temporary:=True)

 

' Atribui diversas características a barra de ferramentas.

With MyBar

Let .Top = 0

Let .Left = 0

Set MyButton = .Controls.Add(Type:=msoControlButton)

 

' PRIMEIRO BOTÃO.

With MyButton

Let .Caption = "&Criando Gráficos"

Let .Style = msoButtonCaption

Let .BeginGroup = True

Let .OnAction = "AssembleChart"    ' Nome da função.

End With

 

' SEGUNDO BOTÃO.

Set MyButton = .Controls.Add(Type:=msoControlButton)

With MyButton

Let .Caption = "&Rotacionando Gráfico"

Let .Style = msoButtonCaption

Let .BeginGroup = True

Let .OnAction = "RotationChart"    ' Nome da função.

End With

Let .Width = 100

Let .Visible = True

End With

End Sub

 

Sub Delete_Menu()

On Error Resume Next

CommandBars("Grafico").Delete

On Error GoTo 0

End Sub

 

Divirtam-se!

 

 

 

Divirta-se!

MS Excel – XlChartType – Tipos de gráficos

Quando você deseja disponibilizar ao seu cliente a opção de escolher o tipo de gráfico com o qual

efetuar análises, você precisa mudar o valor de XlChartType com um valor ou o nome. Listei-os

abaixo para poupar o seu tempo.

With objChart.Chart

.ChartArea.AutoScaleFont = False

.ChartType = xlXYScatterLines

End With

' Nome Valor Descrição

' xl3DArea -4098 Área 3D.

' xl3DAreaStacked 78 Área sobreposta 3D.

' xl3DAreaStacked100 79 Área 100% sobreposta.

' xl3DBarClustered 60 Barra agrupada 3D.

' xl3DBarStacked 61 Barra sobreposta 3D.

' xl3DBarStacked100 62 Barra 100% sobreposta 3D.

' xl3DColumn -4100 Coluna 3D.

' xl3DColumnClustered 54 Coluna agrupada 3D.

' xl3DColumnStacked 55 Coluna sobreposta 3D.

' xl3DColumnStacked100 56 Coluna 100% sobreposta 3D.

' xl3DLine -4101 Linha 3D.

' xl3DPie -4102 Pizza 3D.

' xl3DPieExploded 70 Pizza destacada 3D.

' xlArea 1 Área

' xlAreaStacked 76 Área sobreposta.

' xlAreaStacked100 77 Área 100% sobreposta.

' xlBarClustered 57 Barra agrupada.

' xlBarOfPie 71 Barra de pizza.

' xlBarStacked 58 Barra sobreposta.

' xlBarStacked100 59 Barra 100% sobreposta.

' xlBubble 15 Bolha.

' xlBubble3DEffect 87 Bolha com efeitos 3D.

' xlColumnClustered 51 Coluna agrupada.

' xlColumnStacked 52 Coluna sobreposta.

' xlColumnStacked100 53 Coluna 100% sobreposta.

' xlConeBarClustered 102 Barra cônica agrupada.

' xlConeBarStacked 103 Barra cônica sobreposta.

' xlConeBarStacked100 104 Barra cônica 100% sobreposta.

' xlConeCol 105 Coluna cônica 3D.

' xlConeColClustered 99 Coluna cônica agrupada.

' xlConeColStacked 100 Coluna cônica sobreposta.

' xlConeColStacked100 101 Coluna cônica 100% sobreposta.

' xlCylinderBarClustered 95 Barra cilíndrica agrupada.

' xlCylinderBarStacked 96 Barra cilíndrica sobreposta.

' xlCylinderBarStacked100 97 Barra cilíndrica 100% sobreposta.

' xlCylinderCol 98 Coluna cilíndrica 3D.

' xlCylinderColClustered 92 Coluna cônica agrupada.

' xlCylinderColStacked 93 Coluna cônica sobreposta.

' xlCylinderColStacked100 94 Coluna cilíndrica 100% sobreposta.

' xlDoughnut -4120 Rosca.

' xlDoughnutExploded 80 Rosca destacada.

' xlLine 4 Linha.

' xlLineMarkers 65 Linha com marcadores.

' xlLineMarkersStacked 66 Linhas sobrepostas com marcadores.

' xlLineMarkersStacked100 67 Linha 100% sobreposta com marcadores.

' xlLineStacked 63 Linhas sobrepostas.

' xlLineStacked100 64 Linha 100% sobreposta.

' xlPie 5 Pizza.

' xlPieExploded 69 Pizza destacada.

' xlPieOfPie 68 Pizza de pizza.

' xlPyramidBarClustered 109 Barra piramidal agrupada.

' xlPyramidBarStacked 110 Barras piramidais sobrepostas.

' xlPyramidBarStacked 100 111 Barra piramidal 100% sobreposta.

' xlPyramidCol 112 Colunas piramidais 3D.

' xlPyramidColClustered 106 Colunas piramidais agrupadas.

' xlPyramidColStacked 107 Colunas piramidais sobrepostas.

' xlPyramidColStacked100 108 Colunas piramidais 100% sobrepostas.

' xlRadar -4151 Radar.

' xlRadarFilled 82 Radar preenchido.

' xlRadarMarkers 81 Radar com marcadores de dados.

' xlStockHLC 88 Alta-Baixa-Fechamento.

' xlStockOHLC 89 Abertura-Alta-Baixa-Fechamento.

' xlStockVHLC 90 Volume-Alta-Baixa-Fechamento.

' xlStockVOHLC 91 Volume-Abertura-Alta-Baixa-Fechamento.

' xlSurface 83 Superfície 3D.

' xlSurfaceTopView 85 Superfície (Vista de Cima).

' xlSurfaceTopViewWireframe 86 Superfície (esboço da vista de cima).

' xlSurfaceWireframe 84 Superfície 3D (esboço).

' xlXYScatter -4169 Dispersão.

' xlXYScatterLines 74 Dispersão com linhas.

' xlXYScatterLinesNoMarkers 75 Dispersão com linhas e sem marcadores de dados.

' xlXYScatterSmooth 72 Dispersão com linhas ajustadas.

' xlXYScatterSmoothNoMarkers 73 Dispersão com linhas ajustadas e sem marcadores de dados.

Excel VBA – Retornando nome da Planilha (Return Name of Excel Workbooks or Return the Full File Path)

| Blog Office VBA | Blog Excel | Blog Access |

Disponibilizo abaixo duas funções (UDF's – User Definition Function) que retornarão o nome do arquivo (planilha utilizada). Estas poderão ser aproveitadas tanto em células, como na codificação VBA.

Function SingleFileName() As String
' Author: Date: Contact:
' André Bernardes 24/11/2008 16:37 bernardess@gmail.com
' Retorna apenas o nome do arquivo (Planilha).

Let SingleFileName = ThisWorkbook.Name

End Function

Function FullFileName() As String
' Author: Date: Contact:
' André Bernardes 26/11/2008 09:35 bernardess@gmail.com
' Retorna o Path, bem como o nome do arquivo (Planilha).

    Let FullFileName = ThisWorkbook.FullName

End Function


TAGS: File, Name, FullName, Path, Workbook, Sheet, Active

MS ACCESS – Compactando aplicação ao sair

Invariavelmente precisamos compactar nossas aplicações MS Access

Devido ao acumulo de dados excluídos, transportados, importados, etc...

Um modo de fazer isso sem que interfira demasiadamente na rotina dos

usuários, é por compactar a aplicação ao sair dela.

O código abaixo pode ser executado uma linha antes do comando fechar

da sua aplicação.

Function TomaticCompac()

' A&A - In Any Place. ' André Bernardes. ' Santos - SP. ' Posted in: 19.08.2008 - 10:26. Dim fObject, f, Tam, CompleteFile Dim strProjPath As String, strProjectName As String Let strProjPath = Application.CurrentProject.Path Let strProjName = Application.CurrentProject.Name Let CompleteFile = strProjPath & "\" & strProjName Set fObject = CreateObject("Scripting.FileSystemObject") Set f = fObject.GetFile(CompleteFile) ' Dividindo por mil para converter em MB. Let Tam = CLng(f.Size / 1000000) ' Indica o máximo de tamanho no qual o .MDB pode chegar If Tam > 20 Then ' Compacta a aplicação. Application.SetOption ("Auto Compact"), 1 Application.SetOption "Show Status Bar", True vStatusBar = SysCmd(acSysCmdSetStatus, "Esta aplicação está sendo compactada, por favor não interfira com o processo de Compactação!") Else ' Não compacta a aplicação. Application.SetOption ("Auto Compact"), 0 End If

End Function

ANDRÉ BERNARDES

MS Excel – Formulários Transparentes (Transparent (See through) userforms in Excel)

| Blog Office VBA | Blog Excel | Blog Access |

Este é um recurso útil para utilização em formulários utilizados como Splash
ou em outras áreas onde sua imaginação o tornar aplicável.
O que importa é que vc saiba como fazê-lo.
No módulo do formulário acrescente:
'==============================================================================================
' Microsoft® Office Excel by A&A - In Any Place.
' Copyright© A&A – In Any Place. All Rights Reserved.
'==============================================================================================
Private Declare Function SetWindowLong _
Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes _
Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function FindWindow _
Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong _
Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2&
Public hWnd As Long
Option Explicit
No evento de inicialização do seu formulário, faça uma chamada a função a seguir:
Function OpacityNow()
' Author: Date: Contact:
' André Bernardes 24/11/2008 10:09 bernardess@gmail.com
' Deixando o formulário transparente.
Dim bytOpacity As Byte
Let bytOpacity = 195 ' Nível de opacidade.
Let hWnd = FindWindow ("ThunderDFrame", Me.Caption)
Call SetWindowLong (Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Call SetLayeredWindowAttributes (Me.hWnd, 0, bytOpacity, LWA_ALPHA)
End Function
Boa diversão!

MS Excel - Como efetuar o refresh para todas as pivot tables da minha planilha com VBA?

Simples assim:

Function RefreshPT dim w as worksheet, p as pivottable

for each w in thisworkbook.worksheets for each p in w.pivottables p.refreshtable p.update next next

End Function

MS Excel – Diversas Funções Úteis.

| Blog Office VBA | Blog Excel | Blog Access |

No nosso dia-a-dia sempre acontece de precisarmos de uma funcionalidade útil e na maioria das vezes não gostaríamos de perder muito tempo para desenvolvê-las ou aprender como funcionam.

Para facilitar a sua vida, assim como fizeram comigo anteriormente (pois não tem nada que não tenhamos recebido antes de alguém), coloco abaixo alguns exemplos que espero sejam úteis para você.

Deletando arquivos facilmente, quando estes não estiverem em uso. Caracteres coringas (*) podem ser usados em substituição ao nome do arquivo (Mas cuidado!).

Sub DelFile() 

' Author: André Bernardes 

' Date: 13.10.2008 – 16:10 

' Contact: bernardess@gmail.com 

Dim MyFile As String 'Esta Linha de código é opcional 

On Error Resume Next 'Caso ocorram erros, estes não serão percebidos por usuários. 

Let MyFile = "c:\folder\filename.xls" 

Kill MyFile 

End Sub 

(Des)Protegendo a pasta (worksheet) corrente com uma senha de proteção.

Sub ProtegSheet() 

' Author: André Bernardes 

' Date: 13.10.2008 – 16:10 

' Contact: bernardess@gmail.com

Dim Psswrd ' Esta linha de código é opcional.

Let Psswrd = "bernardes"

ActiveSheet.Protect Psswrd, True, True, True 

End Sub

Sub UnProtegSheet() 

' Author: André Bernardes

 ' Date: 13.10.2008 – 16:10

 ' Contact: bernardess@gmail.com Let Psswrd = "bernardes"

ActiveSheet.Unprotect Psswrd 

End Sub

Protegendo todas as pastas (worksheets) de uma mesma planilha.

Sub ProtegAll() 

' Author: André Bernardes 

' Date: 11.10.2008 – 08:05 

' Contact: bernardess@gmail.com Dim PlansCount 

' Esta linha de código é opcional. Dim j 

' Esta linha de código é opcional.

Let PlansCount = Application.Sheets.Count 

' Retorna quantas pastas (worksheets) contém nesta planilha.

Sheets(1).Select 

' Aqui selecionamos a primeira pasta (worksheet).

For j = 1 To PlansCount ActiveSheet.Protect

If j = PlansCount Then End End If

ActiveSheet.Next.Select Next j 

End Sub

Prevenindo o usuário quanto a área da pasta (worksheets) que não pode ser alterada.

Este exemplo de código previnirá o usuário sobre selecionar células num range (área) específico na pasta (worksheet). Este procedimento pode ser escrito na própria pasta (worksheet) ou num módulo.

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) 

' Author: André Bernardes 

' Date: 10.10.2008 – 17:55 

' Contact: bernardess@gmail.com 

If Not Application.Intersect(Target, Range("A1:A100")) 

Is Nothing Then

Cells(ActiveCell.Row, 2).Select

MsgBox "Descupe, mas não pode selecionar células na faixa: A1:A100!"

End If

End Sub

Como obter o local de atividade da aplicação corrente:

MsgBox "Local de Atividade e nome da pasta: " & CurDir

Como mudar o local de atividade da aplicação:

ChDrive "D" ' changes to the F-station

Como mudar a pasta de atividade atual da aplicação:

ChDir "D:\Meus Documentos\Privado"

Como determinar se um arquivo existe na pasta:

If Dir("D:\Meus Documentos\MyPlan.xls") <> "" Then 

' Quando o arquivo não existe retorna "" (uma string vazia).

Se não especificar o local, o Excel usa o local atual. Se não especificar as pasta, o Excel usa a pasta onde a aplicação está. Como podemos criar uma nova pasta?

MkDir "NovaPastaParticular" ' Cria uma nova pasta no local que a planilha atual está.      

MkDir "D:\Meus Documentos\NovaPastaParticular" ' Cria uma nova pasta no local indicado.

Como apagar uma pasta (A pastas precisa estar vazia):

RmDir "NovaPastaParticular" ' Deleta a subpasta no local onde a planilha atual está.

RmDir "D:\Meus Documentos\NovaPastaParticular" ' Deleta a subpasta no local indicado.

Como copiar um arquivo (o mesmo precisa estar fechado):

FileCopy "Apontamentos.xls", "BAK-Apontamentos.xls" ' Copia-o na pasta local onde a planilha corrente está.

FileCopy "Apontamentos.xls", "X:\BAK-Apontamentos.xls" ' Copia o arquivo na pasta indicada.

Como mover um arquivo (o mesmo precisa estar fechado):

Let Old = "C:\Old\Balanço.xls" ' Localização original do arquivo.

Let New = "C:\New\Balanço.xls" ' Nova localização do arquivo.

Name Old As New ' Move o arquivo.

Tags: VBA, excel, worksheet, sheet, functions, UDF

MS Excel – Navegando entre as pastas na planilhas

Existem diversos modos para se navegar entre as pastas de uma planilha.

Estou postando uma das maneiras mais simples de se fazer isso.

Function SelectSheet()

' Inicia as variáveis.

Dim ThisShts As Variant

Dim mySht As Single

Dim MyList As Variant

' Obtém o número de pastas na planilha.

Let ThisShts = ActiveWorkbook.Sheets.Count

' Carrega o nome das pastas .

For i = 1 To ThisShts

Let MyList = MyList & i & " - " & ActiveWorkbook.Sheets(i).Name & " " & vbCr

Next i

' Mostra os nomes das pastas para serem escolhidas, através dos seus respectivos posicionamentos.

Let mySht = InputBox("Selecione o Nº da pasta e pressione OK:" & vbCr & vbCr & MyList)

Sheets(mySht).Select

End Function

MS Excel – Ordenando pastas Alfabéticamente

| Blog Office VBA | Blog Excel | Blog Access |

Quando me refiro a pasta, estou citando as worksheets das planilhas dentro de um mesmo arquivo workbook

É habitual a utilização de diversas pastas em um mesmo arquivo do MS Excel e, por decorrência, torna-se totalmente necessária que elas estejam organizadas por nome. Geralmente ocorre o contrário: Criamos várias pastas, ordenamos algumas e deixamos outras pelo caminho. No final estamos perdidos com várias pastas perdidas em nossas planilhas.

A funcionalidade que passo a seguir visa automatizar nossa necessidade de organização. Se dermos nomes adequados às nossas pastas, esta rotina fará todo o cansativo e enfadonho serviço de organização por nós, colocando-as em ordem alfabética.

Para ter suas pastas organizadas dentro das suas planilhas, basta que cole o código abaixo em um novo módulo da planilha que deseja organizar, fazendo chamadas a ele. Estas podem ser feitas na abertura e fechamento da mesma, ou através de um comando por combinação de teclas, um botão, ou o que desejar. 

Use a imaginação!

Option Explicit

Function SheetsAlphaSort()

' Author: Date: Contact:

' André Bernardes 13/10/2008 11:07 bernardess@gmail.com

' Ordena de forma alfabética todas as pastas em uma planilha MS Excel.

Dim i As Integer

Dim j As Integer

Dim PrimPastaOrdenar As Integer

Dim UltiPastaOrdenar As Integer

Dim DescrescOrdem As Boolean

Let DescrescOrdem = False

If ActiveWindow.SelectedSheets.Count = 1 Then

'Altera o 1 para o número da pasta que deseja ordenar primeiro.

Let PrimPastaOrdenar = 1

Let UltiPastaOrdenar = Worksheets.Count

Else

With ActiveWindow.SelectedSheets

For i = 2 To .Count

If .Item(i - 1).Index <> .Item(i).Index - 1 Then

MsgBox "Não há como ordenar PASTAS não-adjacentes!"

Exit Sub

End If

Next i

Let PrimPastaOrdenar = .Item(1).Index

Let UltiPastaOrdenar = .Item(.Count).Index

End With

End If

For j = PrimPastaOrdenar To UltiPastaOrdenar

For i = j To UltiPastaOrdenar

If DescrescOrdem = True Then

If UCase(Worksheets(i).Name) > UCase(Worksheets(j).Name) Then

Worksheets(i).Move Before:=Worksheets(j)

End If

Else

If UCase(Worksheets(i).Name) < UCase(Worksheets(j).Name) Then

Worksheets(i).Move Before:=Worksheets(j)

End If

End If

Next i

Next j

End Function

Tags: VBA, Office, Excel, automation, alfabética, ordem, ordenar, ascending, descendin, order, sort, workbook, worksheet, sheet