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 WorksheetDim ACell As RangeDim CCount As LongDim ActiveCellInTable As BooleanDim CopyFormats As VariantDim sheetName As String
'Check to see if the worksheet or workbook is protected.If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True ThenMsgBox "This macro will not work when the workbook or worksheet is write-protected."Exit SubEnd 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 NextActiveCellInTable = (ACell.ListObject.Name <> "")On Error GoTo 0
'If the cell is in a list or table run the code.If ActiveCellInTable = True ThenWith Application.ScreenUpdating = False.EnableEvents = FalseEnd 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 NextWith ACell.ListObject.ListColumns(1).RangeCCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.CountEnd WithOn Error GoTo 0If CCount = 0 ThenMsgBox "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 NextNew_Ws.Name = sheetNameIf Err.Number > 0 ThenMsgBox "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.ClearEnd IfOn Error GoTo 0
'Paste the data into the new worksheet.With New_Ws.Range("A1").PasteSpecial xlPasteColumnWidths.PasteSpecial xlPasteValuesAndNumberFormats.SelectApplication.CutCopyMode = FalseEnd With
'Call the Create List or Table dialog.Application.ScreenUpdating = TrueApplication.CommandBars.FindControl(ID:=7193).ExecuteNew_Ws.Range("A1").SelectActiveCellInTable = FalseOn Error Resume NextActiveCellInTable = (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 ThenApplication.GoTo ACellCopyFormats = MsgBox("Do you also want to copy the Formats?", _vbOKCancel + vbExclamation, "Copy to new worksheet")If CopyFormats = vbOK ThenACell.ListObject.Range.CopyWith New_Ws.Range("A1").PasteSpecial xlPasteFormatsApplication.CutCopyMode = FalseEnd WithEnd IfEnd IfEnd If
'Select the new worksheet if it is not active.Application.GoTo New_Ws.Range("A1")With Application.ScreenUpdating = True.EnableEvents = TrueEnd With
ElseMsgBox "Select a cell in your list or table before you run the macro.", _vbOKOnly, "Copy to new worksheet"End IfEnd SubReference:Tags: VBA, Excel, cell, check, table, list
✔ 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.
VBA Excel - Copiando uma Tabela ou List para uma nova planilha - Copying a Table or List to a New Worksheet in the Current Workbook
Assinar:
Postar comentários (Atom)
Nenhum comentário:
Postar um comentário