VBA Excel - Copiando uma Tabela ou List para uma nova planilha - Copying a Table or List to a New Worksheet in the Current Workbook

Termo de Responsabilidade

O procedimento a seguir copia apenas as células visíveis em uma tabela ou lista para uma nova planilha. O MS Excel tem um limite de 8.192 áreas não contíguas que pode ser copiado em qualquer tabela. 

Este código pergunta-lhe se você deseja criar uma tabela com os novos dados na nova planilha.

Sub CopyListOrTable2NewWorksheet()

'Works in Excel 2003 and Excel 2007. Only copies visible data.

    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

    'Check to see if the worksheet or workbook is protected.

    If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then

        MsgBox "This macro will not work when the workbook or worksheet is write-protected."

        Exit Sub

    End If

    'Set a reference to the ActiveCell. You can always use ACell to

    'point to this cell, no matter where you are in the workbook.

    Set ACell = ActiveCell

    'Test to see if ACell is in a table or list. Note that by using ACell.ListObject, you

    'do not need to know the name of the table to work with it.

    On Error Resume Next

    ActiveCellInTable = (ACell.ListObject.Name <> "")

    On Error GoTo 0

    'If the cell is in a list or table run the code.

    If ActiveCellInTable = True Then

        With Application

            .ScreenUpdating = False

            .EnableEvents = False

        End With

        'Test if there are more than 8192 separate areas. Excel only supports

        'a maximum of 8,192 non-contiguous areas through VBA macros and manual.

        On Error Resume Next

        With ACell.ListObject.ListColumns(1).Range

            CCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count

        End With

        On Error GoTo 0

        If CCount = 0 Then

            MsgBox "There are more than 8192 areas, so it is not possible to " & _

                   "copy the visible data to a new worksheet. Tip: Sort your " & _

                   "data before you apply the filter and try this macro again.", _

                   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.

            sheetName = InputBox("What is the name of the new worksheet?", _

                                 "Name the New Sheet")

            On Error Resume Next

            New_Ws.Name = sheetName

            If Err.Number > 0 Then

                MsgBox "Change the name of sheet : " & New_Ws.Name & _

                     " manually after the macro is ready. The sheet name" & _

                     " you typed in already exists or you use characters" & _

                     " that are not allowed in a sheet name."

                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

                Application.CutCopyMode = False

            End With

            'Call the Create List or Table dialog.

            Application.ScreenUpdating = True

            Application.CommandBars.FindControl(ID:=7193).Execute

            New_Ws.Range("A1").Select

            ActiveCellInTable = False

            On Error Resume Next

            ActiveCellInTable = (New_Ws.Range("A1").ListObject.Name <> "")

            On Error GoTo 0

            Application.ScreenUpdating = False

            'If you do not create a table, you have the option to copy the formats.

            If ActiveCellInTable = False Then

                Application.GoTo ACell

                CopyFormats = MsgBox("Do you also want to copy the Formats?", _

                                     vbOKCancel + vbExclamation, "Copy to new worksheet")

                If CopyFormats = vbOK Then

                    ACell.ListObject.Range.Copy

                    With New_Ws.Range("A1")

                        .PasteSpecial xlPasteFormats

                        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

            .ScreenUpdating = True

            .EnableEvents = True

        End With

    Else

        MsgBox "Select a cell in your list or table before you run the macro.", _

               vbOKOnly, "Copy to new worksheet"

    End If

End Sub

Reference: 

Working with Lists and Tables in Excel 2007: VBA Samples (Part 2 of 2) (May 2009)

Tags: VBA, Excel, cell, check, table, list