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
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
.com