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

Consultancy in Excel, Access, VBA, Dashboards, Scorecards & PowerPoint Projects

DESENVOLVO APLICAÇÕES VBA

Perguntas, Questões e Esclarecimentos

Baixe o Calendário Compacto para 2014 em Excel

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.

André Luiz Bernardes

Professional Profile

| Blog Office VBA | Blog Excel | Blog Access | Blog Infochart | 

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

Consultancy in Excel, Access, VBA, Dashboards, Scorecards & PowerPoint Projects

DESENVOLVO APLICAÇÕES VBA

Perguntas, Questões e Esclarecimentos

Baixe o Calendário Compacto para 2014 em Excel

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

André Luiz Bernardes

Professional Profile

| Blog Office VBA | Blog Excel | Blog Access | Blog Infochart | 

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

Consultancy in Excel, Access, VBA, Dashboards, Scorecards & PowerPoint Projects

Perguntas, Questões e Esclarecimentos

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,