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.

Views

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


Sim, existem diversas formas de descobrirmos e retornarmos o nome de uma planilha, o que segue é mais um modo.

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.




brazilsalesforceeffectiveness@gmail.com

✔ Brazil SFE®Author´s Profile  Google+   Author´s Professional Profile   Pinterest   Author´s Tweets

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

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

brazilsalesforceeffectiveness@gmail.com

✔ Brazil SFE®Author´s Profile  Google+   Author´s Professional Profile   Pinterest   Author´s Tweets

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,
Related Posts Plugin for WordPress, Blogger...

Vitrine

diHITT - Notícias