Views

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

Tags: , , , , , , , , , ,

Nenhum comentário:

Postar um comentário

Assinar: Postar comentários (Atom)
diHITT - Notícias