Views

...

Important:

Quaisquer soluções e/ou desenvolvimento de aplicações pessoais, ou da empresa, que não constem neste Blog podem ser tratados como consultoria freelance.

E-mails

Deixe seu e-mail para receber atualizações...

eBook Promo

VBA Excel - Obtendo informações sobre os pontos no gráfico usando o PointClass - Retrieve Information About Chart Points Using Excel.PointClass

Inline image 1


Este exemplo mostra como obter informações sobre os pontos de um gráfico do MS Excel, como o nome, posições de topo e à esquerda, a largura e a altura.

Vamos aprender a trabalhar com os novos membros da classe Point. Agora podemos obter informações sobre os pontos em um gráfico, incluindo:

  - Nome
  - Início
  - Esquerda
  - Largura
  - Altura

Pontos em um gráfico são numerados a partir da esquerda para a direita na série. Dada a informação sobre o ponto, podemos escrever um código para colocar outras informações sobre o gráfico, ou interagir com estes pontos.

Sub TestPointClass() 
    ' First, create a simple chart that contains points. 
    Range("A1:B1").Value = Array("Region", "Sales") 
    Range("A2:B2").Value = Array("North", 100) 
    Range("A3:B3").Value = Array("South", 200) 
    Range("A4:B4").Value = Array("East", 300) 
    Range("A5:B5").Value = Array("West", 400) 
    
    Dim cht As Chart 
    Set cht = Shapes.AddChart.Chart 
    cht.ChartType = xlLineMarkers 
    cht.SetSourceData Source:=Range("A1:B5") 
    With cht.SeriesCollection(1) 
        .Points(1).MarkerStyle = xlMarkerStyleDiamond 
        .Points(2).MarkerStyle = xlMarkerStyleCircle 
        .Points(3).MarkerStyle = xlMarkerStyleDash 
        .Points(4).MarkerStyle = xlMarkerStyleSquare 
        
        Dim i As Integer 
        For i = 1 To 4 
            DisplayPointProperties .Points(i) 
        Next i 
    End With 
    
End Sub 
Sub DisplayPointProperties(pt As Point) 
    ' Display information about the selected 
    ' point in the Immediate window: 
    Debug.Print "========" 
    Debug.Print "Name:   " & pt.Name 
    Debug.Print "Left:   " & pt.Left 
    Debug.Print "Top :   " & pt.Top 
    Debug.Print "Width:  " & pt.Width 
    Debug.Print "Height: " & pt.Height 
End Sub

Tags: VBA, Excel, Retrieve, Information, Chart, PointClass

Tags: , , , , ,

VBA Excel - Exibe os primeiros 10% de um Range - Display Top Ten Percent in Ranges Programmatically

Inline image 1



Este exemplo mostra como usar o método AddTop10 para exibir os primeiro 10% de uma série de números numa planilha do MS Excel.

Sub DemoAddTop10() 
  ' Fill a range with random numbers. 
  ' Mark the top 10% of items in green, and the bottom 
  ' 10% of the items in red. 
  
  ' Set up a range, and fill it with random numbers. 
  Dim rng As Range 
  Set rng = Range("A1:E10") 
  SetupRangeData rng 
  
  ' Clear any existing format conditions. 
  rng.FormatConditions.Delete 
  
  ' Set up a condition that formats the top 
  ' 10 percent of items on green. 
  Dim fc As Top10 
  Set fc = rng.FormatConditions.AddTop10 
  fc.Percent = True 
  fc.TopBottom = xlTop10Top 
  fc.Interior.Color = vbGreen 
  
  ' Set up a condition that formats the bottom 
  ' 10 percent of items in red. 
  Set fc = rng.FormatConditions.AddTop10 
  fc.TopBottom = xlTop10Bottom 
  fc.Percent = True 
  fc.Interior.Color = vbRed 
End Sub 
Sub SetupRangeData(rng As Range) 
  rng.Formula = "=RANDBETWEEN(1, 100)" 
End Sub 

Tags: VBA, Excel, Display, Top Ten, Percent, Ranges, Programmatically
Tags: , , , , , ,

VBA Excel - Exporte as planilhas para PDF ou XPS - Export Data to PDF or XPS Using the Excel.ExportAsFixedFormat Method

Inline image 1


Este exemplo mostra como usar o método ExportAsFixedFormat para exportar uma série de dados em uma planilha do Microsoft Excel para o formato PDF ou XPS.

Sub TestExportAsFixedFormat() 
  ' For information on the final parameter, see this page: 
  
  Dim rng As Range 
  Set rng = Range("A1:E10") 
  SetupRangeData rng 
  
  Dim fileName As String 
  ' Change this file name to meet your own needs: 
  Let fileName = "C:\Temp\Export.pdf" 
  
  ' Many of these properties are optional, and are included 
  ' here only to demonstrate how you might use them. The 
  ' Type parameter can be one of xlTypePDF and xlTypeXLS; 
  ' the Quality parameter can be one of xlQualityStandard and 
  ' xlQualityMinimum. Setting the OpenAfterPublish property 
  ' to True will fail if you don't have a default viewer 
  ' installed and configured. 
  
  rng.ExportAsFixedFormat Type:=xlTypePDF, _ 
   fileName:=fileName, Quality:=xlQualityStandard, _ 
   IncludeDocProperties:=True, IgnorePrintAreas:=True, _ 
   From:=1, To:=1, OpenAfterPublish:=True 
End Sub 
Sub SetupRangeData(rng As Range) 
  Let rng.Formula = "=RANDBETWEEN(1, 100)" 
End Sub 

Anexos:



Tags: VBA, Excel, Export, Data, PDF, XPS, ExportAsFixed, Format, Method


Tags: , , , , , , , ,

VBA - Retirando os acentos de Planilhas, Textos, Apresentações, bases de dados, etc...



Retirar os acentos de Planilhas, Textos, Apresentações, Bases de Dados, etc....eventualmente também é necessário, seguem códigos úteis para serem colados no seu Editor VBA:

Function removeAcentos (ByVal texto As String) As String    
    Dim vPos As Byte
    
    Const vComAcento = "ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÒÓÔÕÖÙÚÛÜàáâãäåçèéêëìíîïòóôõöùúûü"
    Const vSemAcento = "AAAAAACEEEEIIIIOOOOOUUUUaaaaaaceeeeiiiiooooouuuu"
    
    For i = 1 To Len(texto)
        vPos = InStr(1, vComAcento, Mid(texto, i, 1))
        If vPos > 0 Then
           Mid(texto, i, 1) = Mid(vSemAcento, vPos, 1)
        End If
    Next
    removeAcentos = texto
End Function

Private Sub Command1_Click()
   'exemplo de como chamar
   Text1 = removeAcentos(Text1)
End Sub

Outra opção:
Sub Substituir()
    Cells.Replace What:="é", Replacement:="e", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Cells.Replace What:="É", Replacement:="E", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Cells.Replace What:="á", Replacement:="a", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

    Cells.Replace What:="Á", Replacement:="A", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub

Uma ampliação do código em:
Public Function DLTiraAcentos(ByVal strOriginal As String)
'By JPaulo @ 2009
    Dim strToReturn As String
    strToReturn = ""
    
    Dim i As Integer
    For i = 1 To Len(strOriginal)
        strToReturn = strToReturn & DLTiraAcentos_GetCorrectChar(Mid$(strOriginal, i, 1))
    Next i
    
    DLTiraAcentos = strToReturn
End Function

Public Function DLTiraAcentos_GetCorrectChar(ByVal strChar As String) As String
    Dim LetrasComAcentos As String
    Dim LetrasSemAcentos As String

    LetrasComAcentos = "ÁÍÓÚÉÄÏÖÜËÀÌÒÙÈÃÕÂÎÔÛÊáíóúéäïöüëàìòùèãõâîôûêÇç"
    LetrasSemAcentos = "AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioueCc"

    Dim i As Integer

    For i = 1 To Len(LetrasComAcentos)
        If strChar = Mid$(LetrasComAcentos, i, 1) Then
            DLTiraAcentos_GetCorrectChar = Mid$(LetrasSemAcentos, i, 1)
            Exit Function
        End If
    Next
    
    DLTiraAcentos_GetCorrectChar = strChar
End Function

A criatividade é uma dádiva:
Function Sem_Acento(Acento)
'Desclara variável
Dim tmp$
tmp = Trim(Acento)
For i = 1 To Len(tmp)
x = Asc(Mid(tmp, i, 1))
Select Case x
Case 192 To 197: x = "A"
Case 200 To 203: x = "E"
Case 204 To 207: x = "I"
Case 209: x = "N"
Case 210 To 214: x = "O"
Case 217 To 220: x = "U"
Case 221: x = "Y"
Case 224 To 229: x = "a"
Case 232 To 235: x = "e"
Case 236 To 239: x = "i"
Case 241: x = "n"
Case 240, 242 To 246: x = "o"
Case 249 To 252: x = "u"
Case 253, 255: x = "y"
Case Else: x = Chr(x)
End Select
Sem_Acento = Sem_Acento & x
Next
End Function '

Tags: VBA, dica, trick, tip, acento, diacrítico, retirar
Tags: , , , , , ,

VBA Lotus Notes - Inserindo arquivo - Insert Attach File

Inline image 1




Bem, não tenho o Lotus Notes instalado, este código lhe ensina a anexar:

    Dim AttachME As Object
    Dim EmbedObj1 As Object
    
'   Select Workbook to Attach to E-Mail

    Let notesDocument.SaveMessageOnSend = True
    Let attachment1 = "D:\Bernardes\FileToSend.txt" '    Required File Name

    If attachment1 <> "" Then
        On Error Resume Next
            Set AttachME = MailDoc.CREATERICHTEXTITEM("attachment1")
            Set EmbedObj1 = AttachME.embedobject(1454, "attachment1", "D:\Bernardes\FileToSend.txt", "") 'Required File Name
        On Error Resume Next
    End If


Tags: VBA, Lotus Notes, Lotus, atach, anexar


Tags: , , , ,

VBA Tips - Retornando Milissegundos.

Inline image 1


Hello again folks!


Medir o tempo de processamento de certos momentos dentro da nossa aplicação serve para otimizarmos nosso código, processos, acessos, etc.

Talvez deseje medir a performance de suas queries, ou a geração de arquivos em determinando processo de automação. Talvez queira saber qual interface comporta-se melhor no ambiente para o qual está desenvolvendo.

Como fazer isso, como medir, mensurar, detectar?

Fácil, a função abaixo lhe permitirá tal liberdade.

Public Function MilisSeconds() As String


Let 







MilisSeconds
 
 = Strings.Format(Now, "dd-MMM-yyyy HH:nn:ss") & "." & Strings.Right(Strings.Format(Timer, "#0.00"), 2)
End Function


Mas como posso aplicar isso nas minhas procedures e functions ? Segue exemplo:

Private Sub btnSave_Click()

    ' Author:                     Date:               Contact:

    ' André Bernardes             10/05/2011 15:31    bernardess@gmail.com    http://inanyplace.blogspot.com/

    ' Application: ********.

    ' Cria a **************************************.

    ' Listening: Recognizer - Daft Punk - Tron Legacy.

    Dim nStart As String

    DoCmd.RunCommand acCmdSaveRecord

    Let nStart = Right(TimeInMS(), 11) 'Right(Now(), 8)

    Call AdjustSpecialties


    Call AssemblerCentralEngine

    Call AssemblerCentralEngine2

    Call SeedData                                                    ' Arquiva os dados para consulta e análise posteriores

    Me.cmbCenarios.Requery                                    ' Atualiza o Combo de Exclusão de cenários.

    Let Me.cxVersion.Value = Now() & " Versão 00"   ' Atualiza a caixa de texto onde se dá os nomes para novos cenários.

    MsgBox "Tabela criada com sucesso!" & Chr(10) & Chr(13) & _

"" & Chr(10) & Chr(13) & _

           " TABELA: tbl_Bernardes" & Chr(10) & Chr(13) & _

           "" & Chr(10) & Chr(13) & _

           "CENÁRIO: " & ReturnVersion() & Chr(10) & Chr(13) & _

           "" & Chr(10) & Chr(13) & _

           "Iniciou em: " & nStart & " - Finalizou em: " & Right(TimeInMS(), 11) & Chr(10) & Chr(13) & _

           "" & Chr(10) & Chr(13) & _

           "Os dados foram preservados para análises posteriores." & Chr(10) & Chr(13) & _

           "", vbInformation, ".: Informação: Versão " & ReturnVersion()

End Sub


Existe um outro modo de ter este mesmo resultado, utilizando API e DLL. Não acredito que seja mais útil, mas em todo caso, teste-o você mesmo se desejar:

Private Type SYSTEMTIME


wYear As Integer


wMonth As Integer


wDayOfWeek As Integer


wDay As Integer


wHour As Integer


wMinute As Integer


wSecond As Integer


wMilliseconds As Integer

End Type


Private Declare Sub GetSystemTime Lib "kernel32" 

(lpSystemTime As SYSTEMTIME)

Public Function nMillisecond() As String


Dim tSystem As SYSTEMTIME


Dim nRet

On Error Resume Next

GetSystemTime tSystem

Let sRet = Hour(Now()) & ":" & Minute(Now()) & ":" & Second(Now()) & _

":" & tSystem.wMilliseconds

Let nMillisecond = nRet

End Function


Vocês sabem como sou, se existe um outra forma, e a conheço, não deixo de lhes mostrar (medindo processamento em centésimos de segundos com o métodoTimer):

Public Sub TestBernardes()
    Dim fTimeStart As Single

    Dim fTimeEnd As Single

    Let fTimeStart = Timer

SomeProcedure









Let 
 
fTimeEnd = Timer
Debug.Print Format$((fTimeEnd - fTimeStart) * 100!, "0.00 "" Centésimos de segundos""")

End Sub

Public Sub SomeProcedure()

    Dim i As Long, r As Double

    For i = 0& To 10000000

        Let r = Rnd

    Next
End Sub



Referências: VBAADUD
                      Excel Forum
                 Stack Overflow

Tags: milissegundo, timer, milliseconds


Tags: , ,
Assinar: Postagens (Atom)

eBooks VBA na AMAZOM.com.br

LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...

Vitrine