none
Como Deletar Linhas de uma Planilha ou Tabela de Celulas Selecionadas. RRS feed

  • Pergunta

  • Bom dia.

    Fiz uma rotina para deletar linhas de celulas na planilha e Tabelas  em que as celulas apos selecionadas,  deletava as linhas dessas celulas selecionadas com codigos como abaixo.

    Selection.EntireRow.Select

    Selection.Delete

    O codigo acima funciona bem quando seleciona uma celula ou celulas continuas, mas quando as celulas nao sao continuas, esta dando erro.

    Sera que teria uma forma de deletar linhas de celulas selecionadas nao continuas em:

    1. Planilhas---->As planilhas estao protegidas e o usuario tem acesso limitado, portanto o usuario seleciona as celulas que ele tem acesso e deseja eliminar, e com VBA desprotege ,deleta a linha inteira e volto a proteger.
    2. Tabelas------>Nas planilhas que tem Tabelas, possuem outros dados ao lado dessas Tabelas e quando seleciono celulas que desejo que as linhas dessa Tabela seja eliminada, e nao delete outros dados fora da Tabela como no item1

    Desde ja agradeco a quem possa ajudar

    Tadao



    sexta-feira, 22 de abril de 2016 08:27

Respostas

  • Sobre usar métodos Select: http://ambienteoffice.com.br/blog/gravador-de-macros/#activecell,-select-e-activate

    ---

    Sub Main()
        Dim iArea As Range
        Dim rSelection As Range
        
        Set rSelection = Selection
        
        For Each iArea In rSelection.Areas
            iArea.EntireRow.Delete
        Next iArea
    End Sub
    


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    sábado, 23 de abril de 2016 13:02
    Moderador
  • A rotina é bem mais complexa:

    Sub Main()
        Dim cRows As Collection
        Dim vRows As Variant
        Dim iCell As Variant
        Dim iLO As ListObject
        Dim loOriginal As ListObject
        Dim i As Long
        Dim iRow As Long
        
        Set cRows = New Collection
        
        On Error Resume Next
        Set loOriginal = Selection.Cells(1).ListObject
        If loOriginal Is Nothing Then GoTo Quit
        
        For Each iCell In Selection.Cells
            Set iLO = Nothing
            Set iLO = iCell.ListObject
            If iLO.Name <> loOriginal.Name Then GoTo Continue
            iRow = iCell.Row - loOriginal.HeaderRowRange.Row
            
            cRows.Add iRow, CStr(iRow)
    Continue:
        Next iCell
        On Error GoTo 0
        
        ReDim vRows(1 To cRows.Count)
        For i = 1 To cRows.Count
            vRows(i) = cRows(i)
        Next i
        
        QuickSort vRows
        
        For i = UBound(vRows) To LBound(vRows) Step -1
            loOriginal.ListRows(vRows(i)).Delete
        Next i
        
    Quit:
    End Sub
    
    Private Sub QuickSort(vSort As Variant, _
                          Optional vLow As Variant, _
                          Optional vHigh As Variant)
        'Ordena um vetor utilizando um algoritmo do tipo Quick Sort.
        
        Dim vPivot As Variant
        Dim vSwitch As Variant
        Dim lLow As Long
        Dim lHigh As Long
        
        If IsMissing(vLow) Then vLow = LBound(vSort)
        If IsMissing(vHigh) Then vHigh = UBound(vSort)
        
        lLow = vLow
        lHigh = vHigh
        vPivot = vSort((vLow + vHigh) \ 2)
        Do While lLow <= lHigh
            Do While vSort(lLow) < vPivot And lLow < vHigh
                lLow = lLow + 1
            Loop
            Do While vPivot < vSort(lHigh) And lHigh > vLow
                lHigh = lHigh - 1
            Loop
            If lLow <= lHigh Then
                vSwitch = vSort(lLow)
                vSort(lLow) = vSort(lHigh)
                vSort(lHigh) = vSwitch
                lLow = lLow + 1
                lHigh = lHigh - 1
            End If
        Loop
        
        If vLow < lHigh Then QuickSort vSort, vLow, lHigh
        If lLow < vHigh Then QuickSort vSort, lLow, vHigh
    End Sub
    


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    segunda-feira, 25 de abril de 2016 16:44
    Moderador

Todas as Respostas

  • Sobre usar métodos Select: http://ambienteoffice.com.br/blog/gravador-de-macros/#activecell,-select-e-activate

    ---

    Sub Main()
        Dim iArea As Range
        Dim rSelection As Range
        
        Set rSelection = Selection
        
        For Each iArea In rSelection.Areas
            iArea.EntireRow.Delete
        Next iArea
    End Sub
    


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    sábado, 23 de abril de 2016 13:02
    Moderador
  • Ola Felipe, obrigado pelo retorno.

    Rodei a rotina e funcionou beleza, esse For Each e muito possante,nao?, tem varias utilidades..obrigado pela solucao.

    No segundo caso. tenho uma Tabela conforme fig 1  onde estao selecionados as celulas C5/7/9/10 da  planila ou seja ranges 2,4,6,e,7 da Tabela e gostaria de deletar so as ranges da Tabela e nao a linha inteira da planilha pois afetaria os dados nas colunas A e H.

    Para deletar ranges da Tabela(ListObjects) uso o codigo abaixo:

    ActiveSheet.ListObjects(1).ListRows(n).Delete, sendo n a linha da Tabela que deseja eliminar. Seria o caso de usar o For Each nessa variavel n?...........mas antes teria que tranformar as celulas selecionadas em numero da linha da Tabela?

    Tadao

    fig 1

    domingo, 24 de abril de 2016 11:01
  • A rotina é bem mais complexa:

    Sub Main()
        Dim cRows As Collection
        Dim vRows As Variant
        Dim iCell As Variant
        Dim iLO As ListObject
        Dim loOriginal As ListObject
        Dim i As Long
        Dim iRow As Long
        
        Set cRows = New Collection
        
        On Error Resume Next
        Set loOriginal = Selection.Cells(1).ListObject
        If loOriginal Is Nothing Then GoTo Quit
        
        For Each iCell In Selection.Cells
            Set iLO = Nothing
            Set iLO = iCell.ListObject
            If iLO.Name <> loOriginal.Name Then GoTo Continue
            iRow = iCell.Row - loOriginal.HeaderRowRange.Row
            
            cRows.Add iRow, CStr(iRow)
    Continue:
        Next iCell
        On Error GoTo 0
        
        ReDim vRows(1 To cRows.Count)
        For i = 1 To cRows.Count
            vRows(i) = cRows(i)
        Next i
        
        QuickSort vRows
        
        For i = UBound(vRows) To LBound(vRows) Step -1
            loOriginal.ListRows(vRows(i)).Delete
        Next i
        
    Quit:
    End Sub
    
    Private Sub QuickSort(vSort As Variant, _
                          Optional vLow As Variant, _
                          Optional vHigh As Variant)
        'Ordena um vetor utilizando um algoritmo do tipo Quick Sort.
        
        Dim vPivot As Variant
        Dim vSwitch As Variant
        Dim lLow As Long
        Dim lHigh As Long
        
        If IsMissing(vLow) Then vLow = LBound(vSort)
        If IsMissing(vHigh) Then vHigh = UBound(vSort)
        
        lLow = vLow
        lHigh = vHigh
        vPivot = vSort((vLow + vHigh) \ 2)
        Do While lLow <= lHigh
            Do While vSort(lLow) < vPivot And lLow < vHigh
                lLow = lLow + 1
            Loop
            Do While vPivot < vSort(lHigh) And lHigh > vLow
                lHigh = lHigh - 1
            Loop
            If lLow <= lHigh Then
                vSwitch = vSort(lLow)
                vSort(lLow) = vSort(lHigh)
                vSort(lHigh) = vSwitch
                lLow = lLow + 1
                lHigh = lHigh - 1
            End If
        Loop
        
        If vLow < lHigh Then QuickSort vSort, vLow, lHigh
        If lLow < vHigh Then QuickSort vSort, lLow, vHigh
    End Sub
    


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    segunda-feira, 25 de abril de 2016 16:44
    Moderador
  • Ohhh.....Felipe, funciona que e uma beleza. Realmente e muito complicado,nao?. Ate eu entender o que foi feito.........acho que nao vai dar tempo......vou colocar numa Sub ApgRegTab() e sempre que precisar chamo Call ApgRegTab e......Zip !Zun!,..... Limpa!. Muito obrigado.

    Tadao

    terça-feira, 26 de abril de 2016 03:10
  • Bom dia Felipe, primeiro obrigado pela rotina para deletar as linhas da tabela selecionadas.

    Estava testando na planiha onde vou usar, e deparei que se selecionar a segunda linha ou primeira ate o fim como mostra a fig 1, da erro. Depois de apertar o depurar sae a fig 2. O que deve ser?.

    Uma outra coisa que se puder ajudar, e que fiz uma rotina de evento que ao dar dois clicks na ultima linha da coluna Funcionario, insere uma nova linha para registrar novo funcionario, como mostra o codigo da fig 3. Ela esta funcionado, mas quando deleta todas a linhas, a Tabela ainda fica com uma linha, e se der dois clicks nessa linha da coluna Funcionario, fica esquisito, como devo corrigir o codigo?

    Desde ja agradeco se puder decifrar.

    Tadao

    Fig 1

    Fig 2

    Fig 3

    '==================================================================================
    'Evento qdo der dois clicks na ultima linha da Tablela insere uma linha
    '==================================================================================
    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
    With ActiveSheet
    If Not Intersect(myRange, Target) Is Nothing Then
        Application.EnableEvents = False
        .Unprotect
        .ListObjects(1).ListRows.Add
        With .ListObjects(1)
            .TotalsRowRange.Offset(-1).Select
            Intersect(Range("ShiHody[[Ctr]]"), .TotalsRowRange.Offset(-1)).Value = "Yes"
        End With
        ActiveCell.Offset(1).Select
        .Protect , DrawingObjects:=False
        Application.EnableEvents = True
    Else
        .Unprotect
        .Protect , DrawingObjects:=False
        .EnableSelection = xlUnlockedCells
    End If
    Application.ScreenUpdating = True
    End With
    End Sub
    
    '=============================================================================
    'Funcao MyRange que define como sendo a ultima celula da primeira coluna da Tabela
    '=============================================================================
    Function myRange() As Range
    With ListObjects(1)
        If .ListRows.Count > 0 Then
           Set myRange = .ListRows.Item(.ListRows.Count) _
               .Range.Cells(1, 1)
        Else
           Set myRange = .HeaderRowRange.Offset(1).Cells(1, 1)
        End If
    End With


    sábado, 4 de fevereiro de 2017 08:13
  • Antônio,

    Comigo a rotina funciona normalmente.

    Criei uma tabela, selecionei uma coluna inteira e rodei, apagaram todas as linhas.

    Depois, selecionei da linha 2 até o fim, rodou normalmente também.

    Não faço ideia do que pode ser.


    http://www.ambienteoffice.com.br || Grupo de WhatsApp: https://chat.whatsapp.com/K1uey5Q4yJdKnsgWkVQAZG

    sábado, 4 de fevereiro de 2017 20:03
    Moderador
  • Obrigado,Felipe. Vou tentar analizar melhor para ver a causa.

    Tadao

    sábado, 4 de fevereiro de 2017 23:47