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 listobject. Mostrar todas as postagens
Mostrando postagens com marcador listobject. Mostrar todas as postagens

VBA Excel - Copiando uma tabela ou lista para uma nova planilha


Calendário Compacto para 2014


 O procedimento a seguir copia somente as células visíveis numa tabela ou lista para uma nova planilha. Este código usa o objeto ListObject para representar a tabela ou lista. Um detalhe adicional deste procedimento é o de que o número de ocorrências são não-contíguas.

O Excel tem um limite de 8.192 áreas não contíguas que pode ser copiada para qualquer tabela. O código pergunta se deseja criar uma tabela com os novos dados sobre na nova planilha. Se cancelar esta caixa de diálogo, será perguntado se deseja copiar apenas os formatos de modo que o intervalo pareça profissional.

Sub CopyListOrTable2NewWorksheet()
    Dim New_Ws As Worksheet
    Dim ACell As Range
    Dim CCount As Long
    Dim ActiveCellInTable As Boolean
    Dim CopyFormats As Variant
    Dim sheetName As String

    'Verifique se a planilha ou pasta de trabalho está protegida.
    If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
        MsgBox "Esta macro não funcionará quando a pasta de trabalho ou planilha estiver protegida contra gravação."
        Exit Sub
    End If

    'Definir uma referência ao ActiveCell. Você sempre pode usar a ACell
    'ponto para esta célula, não importa onde você está na pasta de trabalho.
    Set ACell = ActiveCell

'Teste para ver se ACell está em uma tabela ou lista. Note-se que, usando ACell.ListObject, você
     'Não é necessário saber o nome da tabela para trabalhar com ele.
    On Error Resume Next
    Let ActiveCellInTable = (ACell.ListObject.Name <> "")
    On Error GoTo 0

    'Se a célula está em uma lista ou tabela executar o código.
    If ActiveCellInTable = True Then
        With Application
            Let .ScreenUpdating = False
            Let .EnableEvents = False
        End With

        'Testar se existem mais de 8192 áreas separadas. Excel suporta apenas
        'um máximo de 8.192 áreas não contíguas através de macros VBA e manual.
        On Error Resume Next
        With ACell.ListObject.ListColumns(1).Range
            Let CCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
        End With
        On Error GoTo 0

        If CCount = 0 Then
            MsgBox "Há mais de 8192 áreas, de modo que não é possível
copiar os dados visíveis para uma nova planilha. Dica: Classifique os seus dados antes de aplicar o filtro e tente esta macro novamente.", _
                   vbOKOnly, "Copy to new worksheet"
        Else
            'Copy the visible cells.
            ACell.ListObject.Range.Copy

            'Add a new Worksheet.
            Set New_Ws = Worksheets.Add(after:=Sheets(ActiveSheet.Index))

            'Prompt the user for the worksheet name.
            Let sheetName = InputBox("Qual é o nome da nova worksheet?", _
                                 "Name the New Sheet")

            On Error Resume Next
            New_Ws.Name = sheetName
            If Err.Number > 0 Then
                MsgBox "Altere o nome da Aba : " & New_Ws.Name & _
                     " manualmente após a macro está pronta. O nome da sheet" & _
                     " digitada já existe ou você usou caracteres" & _
                     " que não são permitidos."
                Err.Clear
            End If
            On Error GoTo 0

            'Paste the data into the new worksheet.
            With New_Ws.Range("A1")
                .PasteSpecial xlPasteColumnWidths
                .PasteSpecial xlPasteValuesAndNumberFormats
                .Select
                Let Application.CutCopyMode = False
            End With

            'Call the Create List or Table dialog.
            Let Application.ScreenUpdating = True
            Application.CommandBars.FindControl(ID:=7193).Execute
            New_Ws.Range("A1").Select

            Let ActiveCellInTable = False
            On Error Resume Next
            Let ActiveCellInTable = (New_Ws.Range("A1").ListObject.Name <> "")
            On Error GoTo 0

            Let Application.ScreenUpdating = False

            'Se você não criar uma tabela, você tem a opção de copiar os formatos.
            If ActiveCellInTable = False Then
                Application.GoTo ACell
                Let CopyFormats = MsgBox("Você também deseja copiar os formatos?", _
                                     vbOKCancel + vbExclamation, "Copy to new worksheet")
                If CopyFormats = vbOK Then
                    ACell.ListObject.Range.Copy
                    With New_Ws.Range("A1")
                        .PasteSpecial xlPasteFormats
                        Let Application.CutCopyMode = False
                    End With
                End If
            End If
        End If

        'Select the new worksheet if it is not active.
        Application.GoTo New_Ws.Range("A1")

        With Application
            Let .ScreenUpdating = True
            Let .EnableEvents = True
        End With

    Else
        MsgBox "Selecione uma célula na sua lista ou tabela antes de executar a macro.", _
               vbOKOnly, "Copy to new worksheet"
    End If
End Sub



Tags: Excel, VBA, cell, activecell, table, list, Copying, copy, Table, List, Worksheet, Workbook, ListObject
Inline image 1

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

VBA Excel - Interagindo com as Funções AutoFiltro - Excel List AutoFilter VBA




Seguem alguns exemplos de programação VBA para manipular o AutoFiltro do MS Excel, para uso com as listas de dados encontrados nas tabelas das nossas planilhas.

Quando nomeamos estas tabelas de dados constituimos um ListObject, o qual automaticamente recebe a sua própria propriedade AutoFiltro.


Mostrando todos os registros



O código abaixo mostra todos os registros duma lista na planilha ativa, onde um filtro foi aplicado.



Sub ShowAllRecordsList1()

' Mostra todos os registros

Dim Lst As ListObject



Set Lst = ActiveSheet.ListObjects(1)



If Lst.AutoFilter.FilterMode Then

    Lst.AutoFilter.ShowAllData

End If

End Sub


Ligando o AutoFiltro da nossa Lista


Ao usar o código a seguir, você ligará o AutoFiltro do Excel na 1ª lista da planilha ativa.

Sub TurnAutoFilterOnList1()

' Liga o AutoFiltro na 1ª lista.


Dim Lst As ListObject


Set Lst = ActiveSheet.ListObjects (1)


Let Lst.ShowAutoFilter = True

End Sub

Desligando a Lista de AutoFiltro

Utilize o código a seguir para desligar um AutoFiltro do Excel na 1ª lista da planilha ativa.

Sub TurnAutoFilterOffList1()
' Desliga o AutoFiltro na 1ª lista.

Dim Lst As ListObject

Set Lst = ActiveSheet.ListObjects(1)
  
Let Lst.ShowAutoFilter = False
End Sub 

Contando as Listas de AutoFiltros

Para contar todas as listas e tabelas nomeadas duma planilha, onde existem AutoFiltros ativos, usamos o código a seguir.


Sub CountListAutoFilters()

' Conta a Lista de AutoFiltros mesmo que todas as seta fiquem escondidas.



Dim Lst As ListObject

Dim i As Long


Let i = 0



For Each Lst In ActiveSheet.ListObjects

    If Lst.ShowAutoFilter = True Then

    Let i = i + 1

    End If

Next Lst


Debug.Print "Lista de autofiltros: " & i

End Sub

Ocultando todas as Setas da lista de AutoFiltro, exceto uma

Talvez deseje que os seus usuários filtrem apenas uma das colunas da sua primeira Lista. O procedimento VBA  a seguir, esconde as setas de todas as colunas, exceto a segunda coluna da 1ª lista.

Sub HideArrowsList1()
'hides all arrows except list 1 column 2

Dim Lst As ListObject
Dim c As Range
Dim i As Integer

Let Application.ScreenUpdating = False

Set Lst = ActiveSheet.ListObjects(1)

Let i = 1

For Each c In Lst.HeaderRowRange
 If i <> 2 Then
    Lst.Range.AutoFilter Field:=i, _
      VisibleDropDown:=False
 Else
     Lst.Range.AutoFilter Field:=i, _
      VisibleDropDown:=True
 End If

Let i = i + 1
Next

Let Application.ScreenUpdating = True
End Sub 

Ocultando Setas específicas nas listas de AutoFiltro

Talvez, em alguns casos específicos, queiramos ocultar as setas de colunas específicas na nossa lista de dados, deixando as demais setas visíveis. O código a seguir esconde as setas das colunas 1, 3 e 4 na 2ª lista.


Sub HideSpecifiedArrowsList2()
' Esconde setas (arrows) em colunas específicas na 2ª lista.

Dim Lst As ListObject
Dim c As Range
Dim i As Integer

Let Application.ScreenUpdating = False

Set Lst = ActiveSheet.ListObjects(2)

Let i = 1

For Each c In Lst.HeaderRowRange

Select Case i

Case 1, 3, 4

    Lst.Range.AutoFilter Field:=i, _

      Visibledropdown:=False

Case Else

     Lst.Range.AutoFilter Field:=i, _

      Visibledropdown:=True

End Select


Let i = i + 1

Next

Let Application.ScreenUpdating = True
EndSub

Visualizar todas as setas da Lista AutoFiltro

Para mostrar todas as setas da 1ª Lista, podemos usar o código a seguir:


Sub ShowArrowsList1()

Dim Lst As ListObject

Dim c As Range

Dim i As Integer


Let Application.ScreenUpdating = False



Set Lst = ActiveSheet.ListObjects(1)


Let i = 1



For Each c In Lst.HeaderRowRange

  Lst.Range.AutoFilter Field:=i, _

    Visibledropdown:=True

  Let i = i + 1

Next



Let Application.ScreenUpdating = True

End Sub 

Copiando Linhas filtradas específicas, sem os títulos

Este simples código copia somente as linhas filtradas, mas não os respectivos títulos.

A cópia é feita a partir da 1ª Lista na planilha ativa, para uma nova planilha.


Sub CopyFilteredRowsOnlyList1()
Dim wsL As Worksheet
Dim ws As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim Lst As ListObject

Let Application.ScreenUpdating = False

Set wsL = ActiveSheet
Set Lst = wsL.ListObjects(1)

With Lst.AutoFilter.Range

On Error Resume Next


Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _

       .SpecialCells(xlCellTypeVisible)

On Error GoTo 0

End With

If rng2 Is Nothing Then
   MsgBox "Sem dados para copiar."
Else
   Set ws = Sheets.Add
   Set rng = Lst.AutoFilter.Range

   ' Copia todas as linhas sem os cabeçalhos
   rng.Offset(1, 0).Resize(rng.Rows.Count - 1) _
    .SpecialCells(xlCellTypeVisible).Copy _
     Destination:=ws.Range("A1")
End If
   
Let Application.ScreenUpdating = True

End Sub

Copiando Linhas filtradas específicas, com os títulos

O código abaixo copia as linhas filtradas, e as suas respectivas posições, com os títulos.

Sub CopyFilteredRowsAndHeadingsList1()
Dim wsL As Worksheet
Dim ws As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim Lst As ListObject

Let Application.ScreenUpdating = False

Set wsL = ActiveSheet
Set Lst = wsL.ListObjects(1)

With Lst.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
       .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

If rng2 Is Nothing Then
   MsgBox "Sem dados para copiar."
Else
   Set ws = Sheets.Add
   Set rng = Lst.AutoFilter.Range

   ' Copia as Linhas com os seus cabeçalhos.
   rng.SpecialCells(xlCellTypeVisible).Copy _
     Destination:=ws.Range("A1")
End If
   
Let Application.ScreenUpdating = True
End Sub

Conte as Linhas da Lista Visível

Com o exemplo do código a seguir, exibiremos uma mensagem que mostra quantas linhas estão visíveis após a aplicação do filtro:

Sub CountVisibleRowsList1()
Dim Lst As ListObject
Dim rng As Range

Set Lst = ActiveSheet.ListObjects(1)
Set rng = Lst.AutoFilter.Range

MsgBox rng.Columns(1). _
   SpecialCells(xlCellTypeVisible).Count - 1 _
   & " of " & rng _

   .Rows.Count - 1 & " Registros"
End Sub

Tags: VBA, Excel, List, AutoFilter, autofiltro, funções, autofiltro, listobject,  Worksheet , 


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