DONUT PROJECT - VBA - Excel - Populando um ListBox no seu Formulário




Então, digamos que precise criar um pequeno script que permita que os seus usuários selecionem um número de colunas (letras de A a Z) a partir de um ListBox. E em seguida extraiamos os itens selecionados na caixa de listagem.

1
Crie um formulário com uma ListBox chamado Listbox1 e um botão chamado CommandButton1.


2
Crie uma SUB UserForms no seu formulário.



3
Preencha (popule) a ListBox com letras de A a Z:

Private Sub UserForm_Initialize()

' Crie um array.
Dim AlfabetArray() As String

' Defina o conteúdo do array. Aqui podemos separá-las com "|", mas não poderemos usar ",".
Let AlfabetArray = Split("A|B|C|D|E|F|G|H|I|J|K|L|M|N|O|P|Q|R|S|T|U|V|X|Y|Z", "|")

' Populando o Listbox com o array de letras
Let ListBox1.List = AlfabetArray

End Sub


4
Certifique-se de que a caixa de listagem tenha o seu atributo MultiSelect definido como 1 - fmMultiSelectMulti, se você quiser que os usuários possam selecionar vários itens com um clique do mouse.

Selecione 2 - fmMultiSelectExtended, se quiser que os usuários possam usar um  "Ctrl-clique " para selecionar vários itens muito mais rápido.



5
Extraia os itens selecionados do ListBox e insira-os na matriz para uso posterior.

Private Sub CommandButton1_Click()
Dim lItem As Long
Dim BernardNavne() As String    'Array
Dim blDimensioned As Boolean    'Is the array dimensioned?
Dim lngPosition As Long         'Counting
     
Let blDimensioned = False

' Efetua o Loop através de todos os itens no Listbox
For lItem = 0 To Me.ListBox1.ListCount - 1
         
        If Me.ListBox1.Selected(lItem) Then
        ' Se estiver selecionado adicionna-o ao array
        
            'Checamos se o array está corretamente dimensionado
            If blDimensioned = True Then
            ReDim Preserve BernardNavne(0 To UBound(BernardNavne) + 1) As String
            Else
            ReDim BernardNavne(0 To 0) As String
            blDimensioned = True 'flag
            End If
            
            ' Adicionamos a letra ao array
            BernardNavne(UBound(BernardNavne)) = Me.ListBox1.List(lItem)
        End If
Next lItem

'Loop through array to see which items were selected from the Listbox:

For lngPosition = LBound(BernardNavne) To UBound(BernardNavne)
MsgBox BernardNavne(lngPosition)
Next lngPosition
End Sub






André Luiz Bernardes








Inline image 1


DONUT PROJECT - VBA - Excel - Importando arquivos CSV




Importar dados de arquivos CSVs é algo tão comum, que o MS Excel já tem um mecanismo próprio para fazer isso. Mas esta continua sendo uma das dúvidas mais comuns. Como fazer essa importação, através do VBA?

Uma alternativa é a de ler o arquivo CSV como se fosse um arquivo texto, e em seguida carregar cada linha em uma matriz, e através de loops inserí-los no MS Excel.

'This sub only provides the sub ImportCSVfile with parameters

Sub InitiateImportCSVFile()
        Dim filePath As String
        Dim ImportToRow As Integer
        Dim StartColumn As Integer      

        Let filePath = "E:\Bernardes\Arquivo.csv"
        Let ImportToRow = 1 'the row where it will start printing
        Let StartColumn = 1 'the start column

        ImportCSVFile filePath, ImportToRow, StartColumn
End Sub

'  Este é o código que faz todo o trabalho:

Sub ImportCSVFile 
(ByVal filePath As String, ByVal ImportToRow As Integer, ByVal StartColumn As Integer) 

    Dim line As String
    Dim arrayOfElements
    Dim element As Variant

    Open filePath For Input As #1 ' Open file for input

        Do While Not EOF(1) ' Loop until end of file

            ImportToRow = ImportToRow + 1

            Line Input #1, line

            Let arrayOfElements = Split(line, ";") 'Split the line into the array.          

            ' Loop thorugh every element in the array and print to Excelfile

            For Each element In arrayOfElements

                Let Cells(ImportToRow, StartColumn).Value = element

                Let StartColumn = StartColumn + 1

            Next

        Loop

    Close #1 ' Close file.
End Sub





André Luiz Bernardes








Inline image 1

DONUT PROJECT - VBA - Excel - Deletando Conexões de Dados



Sim, nos nossos inúmeros projetos com o MS Excel, invariavelmente faremos conexões às mais diversas bases de dados. E talvez desejemos nos desfazermos delas com o tempo, talvez até mesmo logo após atualizarmos a nossa base de dados na planilha.

Este exemplo mostra como excluir a conexão de dados e desativar a definição de consulta após a importação dos dados ser feita:

' Deleta a conexão

 ActiveWorkbook.Connections(Filnavn).Delete

 Dim qt As QueryTable

' Deleta a query

For Each qt In ActiveSheet.QueryTables

         qt.Delete

 Next qt








André Luiz Bernardes








Inline image 1

DONUT PROJECT - VBA - Excel - Obtendo o Nome da Planilha sem a Extensão - Get name of workbook without extension


Suponha que deseje saber o nome da Planilha (workbook) que está usando no momento, mas que este venha sem a sua respectiva extensão, poderia obtê-lo assim:

Function NameOfWorkbook as String

Let NameOfWorkbook = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))

End Function

A forma de resolver isso foi usando a função InStrRev para encontrar a última ocorrência de "." E a função Left() é usada para designar todos os caracteres a esquerda desta posição para a função NameOfWorkbook.

DONUT PROJECT - VBA - Exportação Automatizada - De *.docx Para *.pdf - Otimizando o tamanho




Este código, desenvolvido no MS Excel, pode reduzir o tamanho de um documento do Word, por exemplo de 400kb para 100kb.

Suponhamos que lhe pedissem alguma forma de reduzir o tamanho de um arquivo *.docx, que inclui algumas fotos. Uma pergunta mais específica seria a de se há algum modo de realmente reduzirmos o tamanho de um documento do MS Word que tenha incorporado imagens *.Jpg? Essa exigência existe devido a necessidade de enviarmos um e-mail com este documento em anexo, pesando menos do que 100 KB. Digamos que a empresa onde trabalha não permita nada acima de 100 KB e por isso tenhamos que descobrir uma maneira de reduzir o tamanho do arquivo. Não há nenhum formato de arquivo especificado ou exigido.

Certamente após refletirmos um pouco, algumas soluções possíveis vieram:

A compactação de arquivos *.Jpeg, salvando-o num formato de arquivo diferente e reinserindo-os no texto.

Capturar um screenshot do documento do MS Word com zoom-out e salvá-lo como um novo arquivo *.Jpg.

Bem, até o momento a melhor solução era realmente fazer screenshots e depois manipulá-los para reduzir o seu tamanho. O único problema era que esse processo seria manual e muito longo, havendo um monte de arquivos para passar.

Após alguns testes com diferentes formatos de arquivo, verificando os resultados (tamanhos). Deparei-me com o recurso de exportação de documento ativo para *.Pdf, mas com a opção de otimização para definir um tamanho mínimo.


Após experimentar isso em cerca de 10 arquivos diferentes, e obter em cada vez, um arquivo menor do que 100 KB de arquivo. Imaginei que seria muito simples abrir um arquivo *.docx e exportá-lo para um arquivo *.pdf. Mas ainda imaginava como automatizaria esse processo. Não sabia a quantidade exata de arquivos que precisavam ser convertidos - apenas tinha a impressão de haver muitos deles.

Então, tive a ideia para o processo de automação, criar uma planilha do MS Excel com algumas macros que:

    • Solicitasse ao usuário para entrar um ou vários arquivos de uma só vez.
    • Abrir cada arquivo.
    • Processar cada arquivo (exportação).
    • Terminar, formatando as células, colocando os resultados em destaque.
Códigos:

Sub Main()
Let Application.ScreenUpdating = False
    Setup
    SelectFilesToConvert
    UpdateConverted
Columns.AutoFit
Let Application.ScreenUpdating = True
End Sub
Private Sub Setup()
    Cells.Clear
    
Let Range("A1") = "Path"    
Let Range("B1") = "Size (KB)"    
Let Range("D1") = "PDF Path"    
Let Range("E1") = "PDF Size (KB)"
 Let Range("E:E").Font.Color = xlNone
 Let Range("B:B", "E:E").NumberFormat = "0.0"
    With Range("A1:E1")
        Let .Interior.Color = RGB(102, 153, 255)
        Let .Borders.LineStyle = xlContinuous
    End With 
End Sub
Private Sub SelectFilesToConvert()
    Dim i As Long
    Dim r As Range
    Set r = Range("A2")
    With Application.FileDialog(msoFileDialogOpen)
        Let .AllowMultiSelect = True        
        Let .InitialFileName = "initial path"
        Let .InitialView = msoFileDialogViewList
        .Filters.Clear
        .Filters.Add "Word Documents", "*.docx"
        .Show
        ' Create hyperlinks to the files and show their size in KB

        For i = 1 To .SelectedItems.Count
            r.Worksheet.Hyperlinks.Add Anchor:=r, Address:=.SelectedItems(i), TextToDisplay:=.SelectedItems(i)
            r.Offset(0, 1) = FileLen(r) / 1000
            ' Open each Word file
            OpenWordFile CStr(r)
            Set r = r.Offset(1, 0)
        Next i
    End With 
End Sub
Private Sub OpenWordFile(filePath As String) 
    On Error GoTo ErrCleanUp
    Dim wordApp As Word.Application
    Set wordApp = New Word.Application
    Let wordApp.DisplayAlerts = wdAlertsNone
    Let wordApp.Visible = False
    Dim wordDoc As Document
    Set wordDoc = wordApp.Documents.Open(filePath)
    SaveAsMinimizedPDF wordDoc 
    Let wordDoc.Saved = True
    wordDoc.Close
    wordApp.Quit
    Exit Sub
ErrCleanUp:
    Let wordDoc.Saved = True
    wordDoc.Close
    wordApp.Quit
End Sub
Private Sub SaveAsMinimizedPDF(ByRef doc As Document)
    doc.ExportAsFixedFormat OutputFileName:= _
 Split(doc.FullName, ".")(0) & ".pdf", ExportFormat:=wdExportFormatPDF _
 , OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForOnScreen, Range _
 :=wdExportAllDocument, From:=1, to:=1, Item:=wdExportDocumentContent, _
 IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
 wdExportCreateNoBookmarks, DocStructureTags:=False, BitmapMissingFonts:= _
 False, UseISO19005_1:=False
End Sub
Private Sub UpdateConverted()
    Dim i As Long
    Dim r As Range

    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Set r = Range("A" & i)
        r.Offset(0, 3).Worksheet.Hyperlinks.Add _
 Anchor:=r.Offset(0, 3), Address:=Split(r, ".")(0) & ".pdf", _
 TextToDisplay:=Split(r, ".")(0) & ".pdf"
        r.Offset(0, 4) = FileLen(r.Offset(0, 3)) / 1000
        ' validate
        r.Offset(0, 4).Font.Color = IIf(r.Offset(0, 4) > 100, RGB(255, 0, 0), RGB(0, 255, 0))
    Next i 
End Sub


Reference: vba4all


VBA Excel - Conte Ocorrências Distintas num Range - Count Distinct Or Unique Values - VBA UDF


Talvez precise contar especificamente quantas ocorrências distintas existem num Range de dados. 

Por exemplo: a, a, b, b, c, d, e, e, f = 5

Aqui está a solução fácil e rápida:

Public Function COUNTDISTINCTcol (ByRef rngToCheck As Range) As Variant
    Dim colDistinct As Collection
    Dim varValues As Variant, varValue As Variant
    Dim lngCount As Long, lngRow As Long, lngCol As Long
    On Error GoTo ErrorHandler
    varValues = rngToCheck.Value
    'if rngToCheck is more than 1 cell then
    'varValues will be a 2 dimensional array
    If IsArray(varValues) Then
        Set colDistinct = New Collection
        For lngRow = LBound(varValues, 1) To UBound(varValues, 1)
            For lngCol = LBound(varValues, 2) To UBound(varValues, 2)
                varValue = varValues(lngRow, lngCol)
                'ignore blank cells and throw error
                'if cell contains an error value
                If LenB(varValue) > 0 Then
                    'if the item already exists then an error will
                    'be thrown which we want to ignore
                    On Error Resume Next
                    colDistinct.Add vbNullString, CStr(varValue)
                    On Error GoTo ErrorHandler
                End If
            Next lngCol
        Next lngRow
        lngCount = colDistinct.Count
    Else
        If LenB(varValues) > 0 Then
            lngCount = 1
        End If
    End If
    COUNTDISTINCTcol = lngCount
    Exit Function
ErrorHandler:
    COUNTDISTINCTcol = CVErr(xlErrValue)
End Function



Tags: Excel, distinct, distinto, occurs, ocorrências,

VBA Tips - 03 das 10 Principais interações com as APIs do Windows - GetComputerName



Quando uma solução VBA está aquém de atender as nossas necessidades, certamente existirá uma função API do Windows que fará o trabalho para nós.

Listo a seguir o que acredito ser uma das 10 Principais interações com as APIs do Windows.


Nós, que desenvolvemos com o VBA no Office, sabemos que podemos pegar alguns atalhos para resolver muitas das nossas necessidades diárias. Às vezes, uma solução pode tornar-se complicada ou difícil para implementarmos. Neste momento lançamos mão das APIs - Application Programming Interface. Sim, encontraremos milhares de funções úteis. E é importante saber que podemos usá-las em quaisquer aplicativos baseados no Windows. (As dicas deste post são específicas para o sistema 32 bits).

Estas funções VBA demonstradas neste artigo não tem o objetivo de serem práticas. Antes, são chamadas simples às APIs, para que possamos ver como trabalham em conjunto. Mas certamente, algumas delas poderão facilmente passar para a sua biblioteca pessoal. Depois que souber como os procedimentos VBA chamam as funções API e o que retornam, poderão modificar tais códigos para usá-los em seus próprios projetos.



3: GetComputerName

Esta função, GetComputerName, é semelhante a GetUserName exceto pelo fato de que recupera o nome no sistema. 

  Private Declare Function GetComputerName Lib "kernel32" Alias _
   "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
  
Function apicGetComputerName() As String
    'Call to apiGetUserName returns current user.
  Dim lngResponse As Long
  Dim strUserName As String * 32
    lngResponse = GetComputerName(strUserName, 32)
  apicGetComputerName = Left(strUserName, InStr(strUserName, Chr$(0)) - 1)
End Function


Tags: VBA, API, code,10, GetComputerName

Inline image 1