VBA Excel - Exportando Gráficos, Tabelas, criando Dashboards

| Blog Office VBA | Blog Excel | Blog Access |

Este artigo visa ampliar a qualidade das aplicações que desenvolvemos por lhes acrescentar uma característica bem desejável, que é a de: 

Enviar o conteúdo das nossas soluções para outros ambientes e interfaces 

Em todas as aplicações da suíte MS Office, a editores gráficos para a criação de Info Gráficos e até mesmo a inserção destes em páginas da Web de modo automatizado (Sharepoint).

Mas talvez esteja se perguntando: Prá que quero isso? Seguem-se diversos códigos bem elaborados que possibilitarão copiar os gráficos das suas planilhas pré-existentes, bem como os ranges de dados destas (conjuntos de células previamente selecionados) quais imagens. 

Detalho:

Por vezes desejará não enviar a fonte de dados junto com o gráfico para um Slide que lhe solicitaram.

Talvez deseje enviar uma tabela, um relatório, partes de um Balanced Scorecard, um Dashboards ou um  Scorecards, ou mesmo um conjunto de KPIs, sem que estes sejam alterados por quem recebê-los.

Criar um informativo regular, parte de um relatório, que envia via MS Outlook, comentários dos

relatórios, agregando conteúdo analítico e não apenas gráficos e dados estáticos para o público alvo.

Como fazê-lo?
Com os recursos abaixo alistados, poderá enviar somente as imagens, como se tirasse uma foto e colasse no Slide, ou num documento do MS Word, no corpo do email e até mesmo no Photoshop (há!).

Chega! Essas são apenas algumas das possibilidades...Pensem em outras...

CÓDIGO: 

ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture


Para copiar um gráfico selecionado (ou ativo) em uma planilha, implemente a seguinte sintaxe:

CÓDIGO: 

ActiveChart.CopyPicture Appearance:=xlScreen, Format:=xlPicture


Copiando um range de dados, colando-a como uma imagem:: 

CÓDIGO: 

Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture


Copie gráficos selecionados (ou ativo) em uma planilha, implemente a seguinte sintaxe:

CÓDIGO: 

Worksheets("Nome da pasta").ChartObjects(1).Chart.CopyPictureAppearance:=xlScreen, Size:=xlScreen, Format:=xlPicture


Copie uma faixa de dados específica, embora não esteja selecionada, colando-a a posteriori::

CÓDIGO: 

Worksheets("Nome da pasta").Range("B11:AF25").CopyPicture Appearance:=xlScreen, Format:=xlPicture


Pois é, sempre existem códigos admiráveis por aí:

CÓDIGO:

Sub GraficoToPowerPoint()
    Dim objPPT As Object
    Dim objPrs As Object
    Dim shtTemp As Worksheet
    Dim chtTemp As ChartObject
    Dim intSlide As Integer
     
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.presentations.Open ThisWorkbook.Path & "\Dashboard_Bernardes.ppt"
    objPPT.ActiveWindow.ViewType = 1 'ppViewSlide
     
    For Each shtTemp In ThisWorkbook.Worksheets
        For Each chtTemp In shtTemp.ChartObjects
            intSlide = intSlide + 1
            chtTemp.CopyPicture
            If intSlide > objPPT.presentations(1).Slides.Count Then
                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.presentations(1).Slides.Add(Index:=intSlide, Layout:=1).SlideIndex
            End If
            objPPT.ActiveWindow.View.Paste
        Next
    Next
    objPPT.presentations(1).Save
    objPPT.Quit
     
    Set objPrs = Nothing
    Set objPPT = Nothing
End Sub

Copiando range e gráfico para o MS Powerpoint:

CÓDIGO:

Sub GraficoRange_TO_Powerpoint() 
    Dim objPPT As Object 
    Dim objPrs As Object 
    Dim objSld As Object 
    Dim shtTemp As Object 
    Dim chtTemp As ChartObject 
    Dim objShape As Shape 
    Dim objGShape As Shape 
    Dim intSlide As Integer 
    Dim blnCopy As Boolean 
     
    Set objPPT = CreateObject("Powerpoint.application") 
    objPPT.Visible = True 
    objPPT.Presentations.Add 
    objPPT.ActiveWindow.ViewType = 1
     
    For Each shtTemp In ThisWorkbook.Sheets 
        blnCopy = False 
        If shtTemp.Type = xlWorksheet Then 
            For Each objShape In shtTemp.Shapes
                blnCopy = False 
                If objShape.Type = msoGroup Then 

                    For Each objGShape In objShape.GroupItems 
                        If objGShape.Type = msoChart Then 
                            blnCopy = True 
                            Exit For 
                        End If 
                    Next 
                End If 
                If objShape.Type = msoChart Then blnCopy = True 
                 
                If blnCopy Then 
                    intSlide = intSlide + 1 
                    objShape.CopyPicture 

                    objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
                    objPPT.ActiveWindow.View.Paste 
                End If 
            Next 
            If Not blnCopy Then 

                intSlide = intSlide + 1 
                shtTemp.UsedRange.CopyPicture 

                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
                objPPT.ActiveWindow.View.Paste 
            End If 
        Else 
            intSlide = intSlide + 1 
            shtTemp.CopyPicture 

            objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
            objPPT.ActiveWindow.View.Paste 
        End If 
    Next 
     
    Set objPrs = Nothing 
    Set objPPT = Nothing 
End Sub

Bônus:

CÓDIGO: 

Sub RangeUsado_TO_Powerpoint()
    Dim objPPT As Object
    Dim shtTemp As Object
    Dim intSlide As Integer
     
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.Presentations.Open ThisWorkbook.Path & "\Bernardes.ppt"
    objPPT.ActiveWindow.ViewType = 1
    
    For Each shtTemp In ThisWorkbook.Sheets
        shtTemp.Range("A1", shtTemp.UsedRange).CopyPicture xlScreen, xlPicture
        intSlide = intSlide + 1

        objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
        objPPT.ActiveWindow.View.Paste
        With objPPT.ActiveWindow.View.Slide.Shapes(objPPT.ActiveWindow.View.Slide.Shapes.Count)
            .Left = (.Parent.Parent.SlideMaster.Width - .Width) / 2
        End With
    Next
     
    Set objPPT = Nothing
End Sub

Boa diversão!

Reference:

VBA POWERPOINT: Atualizando gráfico com dados do MS Excel

Copy Charts To Powerpoint Slides (charts As Sheets)‎
Charts to PowerPoint‎
Copy Chart And Table To Powerpoint‎
export Excel chart to powerpoint‎ 

Inspiration:

André Luiz Bernardes

Tags: VBA, Excel, copy, object, objeto, copiar, chart, gráfico, object, chart, Dashboard, Scorecard

VBA - Brasil, O amadurecimento do nosso legado - Brazil, VBA Development reflections

Quando criei este Blog específico de VBA, a inter-colaboração de códigos VBA inexistia no mercado nacional, ou era muito incipiente. A utilização profissional de Dashboards e Scorecards existia somente como a cópia e adaptação de modestos extravagantes modelos vindos de fora do Brasil, através das corporações que mantinham filiais por aqui. Nestas versões 'traduzidas' dentro dos ambientes corporativos tentava-se espelhar em tais modelos, as informações da filial brasileira ou fazíamos aqui a consolidação da América Latina.

O desenvolvimento VBA naquela época restringia-se as expressão "faz-se macros no excel'. 

Agora em 2012, vivenciamos um mercado de desenvolvimento VBA maduro, cheio de profissionais experientes, Blogs competentíssimos, inúmeras excelentes soluções de desenvolvimento e aplicações de automação disponíveis para várias pessoas baixarem e usarem. 

O mercado nacional está amadurecido e pronto para colaborar com o mercado internacional. Criando soluções e enviado-as as matrizes das empresas.

Tags: VBA, Brasil, Brazil, Mercado, VBA Development

VBA Excel - Caixa de Diálogo - Dialog Box

| Blog Office VBA | Blog Excel | Blog Access | 

Sim, e porque não voltar ao básico? Perfect! 

Revemos o princípio e melhoramos o presente com excelentes perspectivas para o futuro.

Pronto para COPIAR e COLAR - Abra a caixa de diálogo e escolha o arquivo que desejar para o propósito que preferir. 

Primeira opção

Não é raro precisarmos pedir alguma informação para o usuário. Qual a melhor maneira de fazer isso se não usar uma caixa de diálogo?

Sub UserInput()

Dim iReply As Integer

    iReply = MsgBox(Prompt:="Do you wish to run the 'update' Macro", _

            Buttons:=vbYesNoCancel, Title:="UPDATE MACRO")

            

    If iReply = vbYes Then

        Run "UpdateMacro"

    ElseIf iReply = vbNo Then

       'Do Other Stuff

    Else 'They cancelled (VbCancel)

        Exit Sub

    End If

End Sub 

Segunda opção

InputBox(prompt[, title] [, default] [, xpos] [, ypos] [, helpfile, context])

Agora suponhamos que você queira submeter os dados entrados a uma análise prévia e direcionamento...Ahhh, isso seria interessante não é mesmo? Tente isso:

Sub GetUserName()

Dim strName As String

    strName = InputBox(Prompt:="Seu nome,por favor.", _

          Title:="Digite o seu Nome", Default:="Digite seu nome aqui")

          

        If strName = " Digite seu nome aqui " Or _

           strName = vbNullString Then

           Exit Sub

        Else

          Select Case strName

            Case "André"

                'Faça as coisas para o perfil André

            Case "Luiz"

                'Faça as coisas para o perfil Luiz

            Case "Bernardes"

                'Faça as coisas para o perfil Bernardes

            Case Else

                'Faça as coisas para uns perfis mais genéricos 

          End Select

        End If

End Sub

Terceira opção

Dim strFilePath As String, strPath As String
Dim fdgO As FileDialog, varSel As Variant

MsgBox "A tabela não está correta, " &
_
"e o arquivo de dados não pôde ser achado na respectiva pasta: " & _
strPath & ". Por favor,localize a pasta que contenha dados de exemplo " & _
".: Dialog.", vbInformation, gstrAppTitle

Set fdgO = Application.FileDialog(msoFileDialogFilePicker)
With fdgO

.AllowMultiSelect = False

.Title = "Localize a pasta com dados de exemplo"

.ButtonName = "Escolha"

.Filters.Clear

.Filters.Add "All Files", "*.*", 1

.FilterIndex = 1

.InitialFileName = strPath

.InitialView = msoFileDialogViewDetails

If .Show = 0 Then
MsgBox "Houve falha para selecionar o arquivo correto. ATENÇÃO: " & _
"Você talvez não tenha aberto uma tabela conectada a aplicação. " & _
" Você pode re-abrir este formulário ou " & _
"inicie o formulário, tentando novamente.", vbCritical,
gstrAppTitle

Let CheckConnect = False

Exit Function
End If

Let strFilePath = .SelectedItems(1)
End With

Let strPath = Left(strFilePath, InStrRev(strFilePath, "\") - 1)
Let varSel = AttachAgain(strPath)

Quarta opção

Sub GetDat () 
      ' Posiciona num local  específico.
      ChDrive "C: \" 
      ChDir "C: \ Teste \" 

      Let FileToOpen = Application.GetOpenFilename _
      (Title:="Por favor escolha o arquivo a importar:", FileFilter:="Arquivos Excel *.xls (*.xls),")''

      If FileToOpen = False Then

            MsgBox "Arquivo não especificado!", vbExclamation, ":. A&A"

            Exit Sub
      Else
            Workbooks.Open Filename:=FileToOpen
      End If
End Sub


Reference:

• 
  Windows

  
  Office

  
  Windows Phone

  
  Xbox

  
  Skype

  
  Bing

Inspiration:

André Luiz Bernardes

Tags: VBA, Dialog box, message, mensagem, caixa de diálogo

VBA Excel - Deletando Linhas, Linhas em branco e Linhas duplicadas - Delete Rows, Blank Rows, Delete Row on Cell and Delete Duplicate Rows

| Blog Office VBA | Blog Excel | Blog Access | 

Excluir as linhas em branco ou todas as que estiverem duplicadas numa base de dados pode ser facilitado, seguem três códigos: 

DeleteBlankRows

DeleteRowOnCell

DeleteDuplicateRows

O código DeleteBlankRows descrito a seguir irá apagar todas as linhas em branco na planilha especificada pelo parâmetro WorksheetName. Se este for omitido, a planilha ativa será utilizada. O procedimento apagará as linhas que estiverem totalmente em branco ou contiverem células cujo o conteúdo seja apenas um único apóstrofe (caracter que controla a formatação). O procedimento exige a função IsRowClear, mostrada após o procedimento DeleteBlankRows. 

CÓDIGO:

Sub DeleteBlankRows(Optional WorksheetName As Variant)
' This function will delete all blank rows on the worksheet
' named by WorksheetName. This will delete rows that are
' completely blank (every cell = vbNullString) or that have
' cells that contain only an apostrophe (special Text control
' character).
' The code will look at each cell that contains a formula,
' then look at the precedents of that formula, and will not
' delete rows that are a precedent to a formula. This will
' prevent deleting precedents of a formula where those
' precedents are in lower numbered rows than the formula
' (e.g., formula in A10 references A1:A5). If a formula
' references cell that are below (higher row number) the
' last used row (e.g, formula in A10 reference A20:A30 and
' last used row is A15), the refences in the formula will
' be changed due to the deletion of rows above the formula.
'

Dim RefColl As Collection
Dim RowNum As Long
Dim Prec As Range
Dim Rng As Range
Dim DeleteRange As Range
Dim LastRow As Long
Dim FormulaCells As Range
Dim Test As Long
Dim WS As Worksheet
Dim PrecCell As Range

If IsMissing(WorksheetName) = True Then
    Set WS = ActiveSheet
Else
    On Error Resume Next
    Set WS = ActiveWorkbook.Worksheets(WorksheetName)
    If Err.Number <> 0 Then
        '''''''''''''''''''''''''''''''
        ' Invalid worksheet name.
        '''''''''''''''''''''''''''''''
        Exit Sub
    End If
End If
    

If Application.WorksheetFunction.CountA(WS.UsedRange.Cells) = 0 Then
    ''''''''''''''''''''''''''''''
    ' Worksheet is blank. Get Out.
    ''''''''''''''''''''''''''''''
    Exit Sub
End If

''''''''''''''''''''''''''''''''''''''
' Find the last used cell on the
' worksheet.
''''''''''''''''''''''''''''''''''''''
Set Rng = WS.Cells.Find(what:="*", after:=WS.Cells(WS.Rows.Count, WS.Columns.Count), lookat:=xlPart, _
    searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False)

LastRow = Rng.Row

Set RefColl = New Collection

'''''''''''''''''''''''''''''''''''''
' We go from bottom to top to keep
' the references intact, preventing
' #REF errors.
'''''''''''''''''''''''''''''''''''''
For RowNum = LastRow To 1 Step -1
    Set FormulaCells = Nothing
    If Application.WorksheetFunction.CountA(WS.Rows(RowNum)) = 0 Then
        ''''''''''''''''''''''''''''''''''''
        ' There are no non-blank cells in
        ' row R. See if R is in the RefColl
        ' reference Collection. If not,
        ' add row R to the DeleteRange.
        ''''''''''''''''''''''''''''''''''''
        On Error Resume Next
        Test = RefColl(CStr(RowNum))
        If Err.Number <> 0 Then
            ''''''''''''''''''''''''''
            ' R is not in the RefColl
            ' collection. Add it to
            ' the DeleteRange variable.
            ''''''''''''''''''''''''''
            If DeleteRange Is Nothing Then
                Set DeleteRange = WS.Rows(RowNum)
            Else
                Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
            End If
        Else
            ''''''''''''''''''''''''''
            ' R is in the collection.
            ' Do nothing.
            ''''''''''''''''''''''''''
        End If
        On Error GoTo 0
        Err.Clear
    Else
        '''''''''''''''''''''''''''''''''''''
        ' CountA > 0. Find the cells
        ' containing formula, and for
        ' each cell with a formula, find
        ' its precedents. Add the row number
        ' of each precedent to the RefColl
        ' collection.
        '''''''''''''''''''''''''''''''''''''
        If IsRowClear(RowNum:=RowNum) = True Then
            '''''''''''''''''''''''''''''''''
            ' Row contains nothing but blank
            ' cells or cells with only an
            ' apostrophe. Cells that contain
            ' only an apostrophe are counted
            ' by CountA, so we use IsRowClear
            ' to test for only apostrophes.
            ' Test if this row is in the
            ' RefColl collection. If it is
            ' not in the collection, add it
            ' to the DeleteRange.
            '''''''''''''''''''''''''''''''''
            On Error Resume Next
            Test = RefColl(CStr(RowNum))
            If Err.Number = 0 Then
                ''''''''''''''''''''''''''''''''''''''
                ' Row exists in RefColl. That means
                ' a formula is referencing this row.
                ' Do not delete the row.
                ''''''''''''''''''''''''''''''''''''''
            Else
                If DeleteRange Is Nothing Then
                    Set DeleteRange = WS.Rows(RowNum)
                Else
                    Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
                End If
            End If
        Else
            On Error Resume Next
            Set FormulaCells = Nothing
            Set FormulaCells = WS.Rows(RowNum).SpecialCells(xlCellTypeFormulas)
            On Error GoTo 0
            If FormulaCells Is Nothing Then
                '''''''''''''''''''''''''
                ' No formulas found. Do
                ' nothing.
                '''''''''''''''''''''''''
            Else
                '''''''''''''''''''''''''''''''''''''''''''''''''''
                ' Formulas found. Loop through the formula
                ' cells, and for each cell, find its precedents
                ' and add the row number of each precedent cell
                ' to the RefColl collection.
                '''''''''''''''''''''''''''''''''''''''''''''''''''
                On Error Resume Next
                For Each Rng In FormulaCells.Cells
                    For Each Prec In Rng.Precedents.Cells
                        RefColl.Add Item:=Prec.Row, key:=CStr(Prec.Row)
                    Next Prec
                Next Rng
                On Error GoTo 0
            End If
        End If
        
    End If
    
    '''''''''''''''''''''''''
    ' Go to the next row,
    ' moving upwards.
    '''''''''''''''''''''''''
Next RowNum


''''''''''''''''''''''''''''''''''''''''''
' If we have rows to delete, delete them.
''''''''''''''''''''''''''''''''''''''''''

If Not DeleteRange Is Nothing Then
    DeleteRange.EntireRow.Delete shift:=xlShiftUp
End If

End Sub
Function IsRowClear(RowNum As Long) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''
' IsRowClear
' This procedure returns True if all the cells
' in the row specified by RowNum as empty or
' contains only a "'" character. It returns False
' if the row contains only data or formulas.
''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ColNdx As Long
Dim Rng As Range
ColNdx = 1
Set Rng = Cells(RowNum, ColNdx)
Do Until ColNdx = Columns.Count
    If (Rng.HasFormula = True) Or (Rng.Value <> vbNullString) Then
        IsRowClear = False
        Exit Function
    End If
    Set Rng = Cells(RowNum, ColNdx).End(xlToRight)
    ColNdx = Rng.Column
Loop

IsRowClear = True

End Function


Este código, DeleteBlankRows, excluirá uma linha, se ela estiver toda em branco. Apagará a linha inteira se uma célula na coluna especificada estiver em branco. Somente a coluna marcada, outras serão ignoradas.

CÓDIGO:

Public Sub DeleteRowOnCell() 

         On Error Resume Next 

         Selection.SpecialCells (xlCellTypeBlanks). EntireRow.Delete 

         ActiveSheet.UsedRange 

End Sub


Para usar este código, selecione um intervalo de células por colunas e, em seguida, execute o código. Se a célula na coluna estiver em branco, a linha inteira será excluída. Para processar toda a coluna, clique no cabeçalho da coluna para selecionar a coluna inteira.

Este código eliminará as linhas duplicadas em um intervalo. Para usar, selecione uma coluna como intervalo de células, que compreende o intervalo de linhas duplicadas a serem excluídas. Somente a coluna selecionada é usada para comparação. 

CÓDIGO: 

Sub DeleteDuplicateRows Pública () 
''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''' 
'DeleteDuplicateRows 
"Isto irá apagar registros duplicados, com base na coluna ativa. Ou seja, 
"se o mesmo valor é encontrado mais de uma vez na coluna activa, mas todos 
"os primeiros (linha número mais baixo) serão excluídos. 
" 
'Para executar a macro, selecione a coluna inteira que você deseja escanear 
'duplica e executar este procedimento. 
'''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''' 

R Dim As Long 
Dim N Long 
V Variant Dim 
Dim Rng Gama 

On Error GoTo EndMacro 
Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 


Set Rng = Application.Intersect (ActiveSheet.UsedRange, _ 
ActiveSheet.Columns (ActiveCell.Column)) 

Application.StatusBar = "Processamento de Linha:" & Format (Rng.Row , "#,## 0 ") 

N = 0 
para R = Rng.Rows.Count To 2 Step -1 
Se Mod R 500 = 0 Then 
Application.StatusBar = "Linha de processamento:" & Format (R ", # # 0 ") 
End If 

= Rng.Cells (R, 1). Valor V 
'''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''' 
Nota "que COUNTIF obras estranhamente com uma variante que é igual a vbNullString. 
" Ao invés de passar na variante, você precisa passar vbNullString explicitamente. 
''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''' 
Se V = vbNullString Então 
Se Application.WorksheetFunction. CONT.SE (Rng.Columns (1), vbNullString)> 1 Então 
Rng.Rows (R). EntireRow.Delete 
N = N + 1 
End If 
Else 
Se Application.WorksheetFunction.CountIf (Rng.Columns (1), V)> 1 Então, 
(R). Rng.Rows EntireRow.Delete 
N = N + 1 
End If 
End If 
Next R 

EndMacro: 

Application.StatusBar = False 
Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 
MsgBox "Duplicar linhas excluídas:" & CStr (N ) 

End Sub


Reference:

Inspiration:

André Luiz Bernardes

Tags: VBA, delete, row, blank, cell, duplicate

VBA Excel - Detectar a última Célula da Planilha - Detecting a last cell

| Blog Office VBA | Blog Excel | Blog Access | 

Esse código é para iniciantes faixas brancas: Como identificar a última célula e portanto a última linha da planilha.

Planilhas constantemente manipuláveis, cujos os dados não são conexões em bases de dados, mas dados colados através de CTRL + V, tendem a deixar dirty areas. Estas acabam por dificultar a detecção da última célula. O exemplo abaixo é uma técnica para teste naquelas bases de dados enormes, com grandes quantidades de dados, acima de 100.000 linhas, as quais devem dar constantes dores de cabeça àqueles que ainda não dominam as técnicas de conexão do MS Excel com o MS Access.

CÓDIGO: 

Function LCell(ws As Worksheet) As Range
  Dim LRow&, LCol%

  On Error Resume Next

  With ws
    Let LRow& = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Let LCol%   = .Cells.Find(What:="*", SearchDirection:=xlPrevious,  SearchOrder:=xlByColumns).Column
  End With

  Set LCell = ws.Cells(LRow&, LCol%)
End Function

Usando esta função:
A função LCell demonstrada aqui não pode ser usada diretamente na planilha, mas pode ser evocada a partir de outra SUB VBA, implemente o código conforme demonstrado abaixo:

CÓDIGO: 

Sub Identifica()
   MsgBox LCell(Sheet1).Row
End Sub

Ahhh, e sempre se pode melhorar:

Function LRow (Rg as Range) As Long

    Dim ix As Long

    Let ix = rg.parent.UsedRange.Row - 1 + rg.parent.UsedRange.Rows.Count 

    Let LRow = ix 

End Function

Reference:

Bob Umlas

Inspiration:

André Luiz Bernardes

Tags: VBA, Tips, dummy, dummies, row, last, cell, célula, dirty area, detect, detectar