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

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,
Assinar: Postagens (Atom)

eBooks VBA na AMAZOM.com.br

LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...

Vitrine