Propósito

✔ Programação GLOBAL® - Quaisquer soluções e/ou desenvolvimento de aplicações pessoais, ou da empresa, que não constem neste Blog devem ser tratados como consultoria freelance. Queiram contatar-nos: brazilsalesforceeffectiveness@gmail.com | ESTE BLOG NÃO SE RESPONSABILIZA POR QUAISQUER DANOS PROVENIENTES DO USO DOS CÓDIGOS AQUI POSTADOS EM APLICAÇÕES PESSOAIS OU DE TERCEIROS.

.: Vitrine

Carregando artigos...

Views

Mostrando postagens com marcador last. Mostrar todas as postagens
Mostrando postagens com marcador last. Mostrar todas as postagens

VBA Excel - Definindo a última linha - How To Delete Rows

Recebi um monte de perguntas sobre qual o melhor modo de excluirmos linhas no MS Excel, dadas várias condições. 

Montei alguns exemplos que devem ajudá-los a começar caso precisem enfrentar tal tarefa. 

Este post é uma coletânea de exemplos de código VBA - não um tutorial.

Determinando a última linha usada

Use este código ao longo da linha para determinar a última linha com dados num intervalo especificado:

Public Function GetLastRow (ByVal rngToCheck As Range) As Long

    Dim rngLast As Range
    
    Set rngLast = rngToCheck.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious)
    
    If rngLast Is Nothing Then
        Let GetLastRow = rngToCheck.Row
    Else
        Let GetLastRow = rngLast.Row
    End If
    
End Function

Exclua a linha se determinada célula, na coluna, estiver vazia

Este código é apenas uma 'carcaça' modelo que demonstra a maneira mais rápida e simples de excluirmos cada linha da Aba (Sheet1), se as células na coluna A estiverem vazias:

Sub Example1()

    Dim lngLastRow As Long
    Dim rngToCheck As Range

    Let Application.ScreenUpdating = False

    With Sheet1
        'if the sheet is empty then exit...
        If Application.WorksheetFunction.CountA(.Cells) > 0 Then

            'find the last row in the worksheet
            Let lngLastRow = GetLastRow(.Cells)
            
            Set rngToCheck = .Range(.Cells(1, 1), .Cells(lngLastRow, 1))
        
            If rngToCheck.Count > 1 Then
                'if there are no blank cells then there will be an error
                On Error Resume Next
                rngToCheck.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                On Error GoTo 0
            Else
                If VBA.IsEmpty(rngToCheck) Then rngToCheck.EntireRow.Delete
            End If
        End If
    End With
    
    Let Application.ScreenUpdating = True

End Sub

Excluir linhas, se as células na mesma linha estiverem vazias

Este exemplo sobrepõe o anterior, mas apresenta outra nuance quando se trabalha com o método de intervalo do objeto SpecialCells. Este exemplo excluirá todas as linhas na planilha,quando qualquer uma das suas células nas colunas de B a E estiverem vazias. 


Sub Example1()

    Dim lngLastRow As Long
    Dim rngToCheck As Range, rngToDelete As Range

    Let Application.ScreenUpdating = False

    With Sheet1

        
        'find the last row on the sheet
        Let lngLastRow = GetLastRow(.Cells)
        
        If lngLastRow > 1 Then
            'we want to check the used range in columns B to E
            'except for our header row which is row 1
            Set rngToCheck = .Range(.Cells(2, "b"), .Cells(lngLastRow, "e"))
        
            'if there are no blank cells then there will be an error
            On Error Resume Next
            Set rngToDelete = rngToCheck.SpecialCells(xlCellTypeBlanks)
            On Error GoTo 0
            
            'allow for overlapping ranges
            If Not rngToDelete Is Nothing Then _
                    Application.Intersect(.Range("A:A"), rngToDelete.EntireRow).EntireRow.Delete
        End If
    End With
    
    Let Application.ScreenUpdating = True
End Sub

Use o objeto Range para encontrar Método

A abordagem mais tradicional para resolver esta tarefa é percorrer toda a coluna, verificar se cada célula contém o valor e, se isso acontecer, excluir a linha. Como o Excel desloca as linhas para cima quando forem excluídas, é melhor começarmos na parte inferior da coluna.

Sub Example1()

    Const strTOFIND As String = "Hello"

    Dim rngFound As Range, rngToDelete As Range
    Dim strFirstAddress As String
    
    Let Application.ScreenUpdating = False
    
    With Sheet1.Range("A:A")
        Set rngFound = .Find( _
                            What:=strTOFIND, _
                            Lookat:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=True)
        
        If Not rngFound Is Nothing Then
            Set rngToDelete = rngFound

            'note the address of the first found cell so we know where we started.
            strFirstAddress = rngFound.Address
            
            Set rngFound = .FindNext(After:=rngFound)
            
            Do Until rngFound.Address = strFirstAddress
                Set rngToDelete = Application.Union(rngToDelete, rngFound)
                Set rngFound = .FindNext(After:=rngFound)
            Loop
        End If
    End With
    
    If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
    
    Let Application.ScreenUpdating = True

End Sub

Usando o método Range com o Autofiltro

Claro, este procedimento pressupõe que a Linha 1 contém cabeçalhos de campo.


Sub Example2()

    Const strTOFIND As String = "Hello"
    
    Dim lngLastRow As Long
    Dim rngToCheck As Range
    
    Let Application.ScreenUpdating = False

    
    With Sheet1
        'find the last row in the Sheet
        Let lngLastRow = GetLastRow(.Cells)
        
        Set rngToCheck = .Range(.Cells(1, 1), .Cells(lngLastRow, 1))
    End With
    
    With rngToCheck
        .AutoFilter Field:=1, Criteria1:=strTOFIND
        
        'assume the first row had headers
        On Error Resume Next
        .Offset(1, 0).Resize(.Rows.Count - 1, 1). _
            SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0
        
        'remove the autofilter
        .AutoFilter
    End With

    Let Application.ScreenUpdating = True

End Sub

Usando o objeto Range com o método ColumnDifferences

o código abaixo é muito semelhante ao anterior, exceto pela aplicação de uma lógica inversa. Apesar de invertemos a lógica do Range.Autofilter a abordagem será bem simples, está ligeiramente diferente com o método Range.Find.

Sub Example1()
    Const strTOFIND As String = "Hello"

    Dim lngLastRow As Long
    Dim rngToCheck As Range
    Dim rngFound As Range, rngToDelete As Range
    
    Let Application.ScreenUpdating = False
    
    With Sheet1
        Let lngLastRow = GetLastRow(.Cells)
        
        If lngLastRow > 1 Then
            'we don't want to delete our header row
            With .Range("A2:A" & lngLastRow)
            
                Set rngFound = .Find( _
                                    What:=strTOFIND, _
                                    Lookat:=xlWhole, _
                                    SearchOrder:=xlByRows, _
                                    SearchDirection:=xlNext, _
                                    MatchCase:=True)
            
                If rngFound Is Nothing Then
                    'there are no cells we want to keep!
                    .EntireRow.Delete                    
                Else            
                    'determine all the cells in the range which have a different value
                    On Error Resume Next
                    Set rngToDelete = .ColumnDifferences(Comparison:=rngFound)
                    On Error GoTo 0
                    
                    If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
                    
                End If
            End With
        End If
    End With
    
    Let Application.ScreenUpdating = True
End Sub


Deixe os seus comentários! Envie este artigo, divulgue este link na sua rede social...


Tags: VBA, Excel, last, row, última, linha, getlastrow, 
Nenhum comentário:
Tags: , , , , , ,

VBA Excel - Retorna a Última Linha de uma planilha

Function LastRow (nColumn As String, InitLine As Single) As Single
    ' Author:                     Date:               Contact:
    ' André Bernardes             11/08/2008 09:01    bernardess@gmail.com
    ' Retorna o número de ocorrências.

    Dim nLine As Single
    Dim nStart As Single
    Dim nFinito As Single
    Dim Cabessalho As Single
    Dim nCeo As String

    Application.Volatile

    Let nStart = InitLine + 1
    Let nFinito = 65000
    Let Cabessalho = InitLine

    Do While nStart < nFinito
        Let nCeo = nColumn & Trim(Str(nStart))

        If Application.ActiveSheet.Range(nCeo).Value = "" Then
            Exit Do
        End If

        'Let Application.StatusBar.Value = " Linha: " & nStart
        Let nStart = nStart + 1
    Loop

    Let LastRow = (nStart - 1) '- Cabeçalho
    'Let Application.StatusBar.Value = "  "
End Function


brazilsalesforceeffectiveness@gmail.com


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

Nenhum comentário:
Tags: , , , , , ,

VBA Excel - Retornando o Limite da Coluna de um Range



Como faço para descobrir a última coluna com dados numa Planilha?

Function LASTINCOLUMN (rngInput As Range)
    ' Author:                     Date:               Contact:
    ' André Bernardes             11/08/2008 09:01    bernardess@gmail.com
    '
    Dim WorkRange As Range
    Dim i As Integer, CellCount As Integer
    
    Application.Volatile

    Set WorkRange = rngInput.Columns(1).EntireColumn
    Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
    
    Let CellCount = WorkRange.Count

    For i = CellCount To 1 Step -1
        If Not IsEmpty(WorkRange(i)) Then
            Let LASTINCOLUMN = WorkRange(i).Value
            Exit Function
        End If
    Next i
End Function


Tags: VBA, Excel, UDF, Column, coluna, last, última




Nenhum comentário:
Tags: , , , , , ,

VBA Excel - Juntando distintas planilhas - Combine worksheets in Excel and Kill all excel objects

Inline image 1

Quando estamos trabalhando com várias planilhas, não raramente centenas delas, e precisamos elaborar uma análise, um relatório, importá-las para uma base de dados, etc...Tudo isso seria mais fácil se ao invés de termos centenas de arquivos, tivéssemos acesso a somente uma planilha contendo os dados de todas as demais. Sim, meus caros, nos pouparia muito tempo. E como sempre nos vem a pergunta: Como?

Segue:

Sub CopyFromWorksheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Long
'Dim sheetDelimiter As String
' Creates excel app object
Set objExcel = CreateObject("Excel.Application")
   
' Makes the excel invisible
objExcel.Visible = False
' Supress all display alerts
objExcel.DisplayAlerts = False
' Gets the complete path of the active excel sheet
strExcelFilePath = ActiveWorkbook.FullName
  
' Opens the excel file
Set objWorkbook = objExcel.Workbooks.Open(Trim(strExcelFilePath))

Set objWorkSheet = objWorkbook.Worksheets("Merge")
objWorkSheet.Activate
' Gets the count of column
Set objRange = objWorkbook.Worksheets("Merge")
numRowsCount = objRange.Evaluate("COUNTA(A1:A100)")
Worksheets("Merge").Activate
'sheetDelimiter = "######"
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Consolidated Backlog" Then
MsgBox "There is a worksheet called as 'Consolidated Backlog'." & vbCrLf & _
"Please remove or rename this worksheet since 'Consolidated Backlog' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
Application.ScreenUpdating = False
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = "Consolidated Backlog"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = 30

For cntLoop = 1 To numRowsCount
     strSheetName = Trim(UCase(objExcel.Cells(cntLoop, 1).Value))
     If Trim(strSheetName) = "" Then
        Exit For
     End If
     If Trim(strSheetName) = "SHEET NAMES" Then
       GoTo Continue
     End If
     For Each sht In wrk.Worksheets
        'If worksheet in loop is the last one, stop execution (it is Master worksheet)
        If sht.Index = wrk.Worksheets.Count Then Exit For
        If strSheetName = UCase(sht.Name) Then
            'Delimits the copied sheets with a string in a new row
            With trg.Cells(1, 1).Resize(1, colCount)
                .Value = sht.Cells(1, 1).Resize(1, colCount).Value
                 'Set font as bold
                .Font.Bold = True
            End With
            
            trg.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(1, 1).Value = sheetDelimiter
            Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(Rows.Count, 1).End(xlUp).Resize(, colCount))
            rng.Copy trg.Cells(Rows.Count, 1).End(xlUp).Offset(1)
            'Set objRange = sht.Range("A1").EntireColumn
            'objRange.Insert (xlShiftToRight)
            'sht.Range("A1") = sht.Name
        End If
    Next sht
Continue:
Next
objExcel.Quit
Set objWorkbook = Nothing
Set objExcel = Nothing
Set sht = Nothing
Set objWorkSheet = Nothing
Set objRange = Nothing
Set trg = Nothing
Set rng = Nothing
Application.ScreenUpdating = True
'create WMI object instance
Set objWMI = GetObject("winmgmts:")
If Not IsNull(objWMI) Then
'create object collection of Win32 processes
Set objProcList = objWMI.InstancesOf("win32_process")
For Each objProc In objProcList 'iterate through enumerated
If UCase(objProc.Name) = UCase(procName) Then
objProc.Terminate (0)
End If
Next
End If
Set objProcList = Nothing
Set objWMI = Nothing

End Sub

Reference:

Aditya Kalra

Inspiration:
André Luiz Bernardes

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

Nenhum comentário:
Tags: , , , , , , , , , ,
Assinar: Postagens (Atom)
diHITT - Notícias