· 8 years ago · Mar 10, 2018, 01:46 PM
1Sub CopyListOrTable2NewWorksheet()
2'Works in Excel 2003 and Excel 2007. Only copies visible data.
3 Dim New_Ws As Worksheet
4 Dim ACell As Range
5 Dim CCount As Long
6 Dim ActiveCellInTable As Boolean
7 Dim CopyFormats As Variant
8 Dim sheetName As String
9
10 'Check to see if the worksheet or workbook is protected.
11 If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
12 MsgBox "This macro will not work when the workbook or worksheet is write-protected."
13 Exit Sub
14 End If
15
16 'Set a reference to the ActiveCell. You can always use ACell to
17 'point to this cell, no matter where you are in the workbook.
18 Set ACell = ActiveCell
19
20 'Test to see if ACell is in a table or list. Note that by using ACell.ListObject, you
21 'do not need to know the name of the table to work with it.
22 On Error Resume Next
23 ActiveCellInTable = (ACell.ListObject.Name <> "")
24 On Error GoTo 0
25
26 'If the cell is in a list or table run the code.
27 If ActiveCellInTable = True Then
28 With Application
29 .ScreenUpdating = False
30 .EnableEvents = False
31 End With
32
33 'Test if there are more than 8192 separate areas. Excel only supports
34 'a maximum of 8,192 non-contiguous areas through VBA macros and manual.
35 On Error Resume Next
36 With ACell.ListObject.ListColumns(1).Range
37 CCount = .SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
38 End With
39 On Error GoTo 0
40
41 If CCount = 0 Then
42 MsgBox "There are more than 8192 areas, so it is not possible to " & _
43 "copy the visible data to a new worksheet. Tip: Sort your " & _
44 "data before you apply the filter and try this macro again.", _
45 vbOKOnly, "Copy to new worksheet"
46 Else
47 'Copy the visible cells.
48 ACell.ListObject.Range.Copy
49
50 'Add a new Worksheet.
51 Set New_Ws = Worksheets.Add(after:=Sheets(ActiveSheet.Index))
52
53 'Prompt the user for the worksheet name.
54 sheetName = InputBox("What is the name of the new worksheet?", _
55 "Name the New Sheet")
56
57 On Error Resume Next
58 New_Ws.Name = sheetName
59 If Err.Number > 0 Then
60 MsgBox "Change the name of sheet : " & New_Ws.Name & _
61 " manually after the macro is ready. The sheet name" & _
62 " you typed in already exists or you use characters" & _
63 " that are not allowed in a sheet name."
64 Err.Clear
65 End If
66 On Error GoTo 0
67
68 'Paste the data into the new worksheet.
69 With New_Ws.Range("A1")
70 .PasteSpecial xlPasteColumnWidths
71 .PasteSpecial xlPasteValuesAndNumberFormats
72 .Select
73 Application.CutCopyMode = False
74 End With
75
76 'Call the Create List or Table dialog.
77 Application.ScreenUpdating = True
78 Application.CommandBars.FindControl(ID:=7193).Execute
79 New_Ws.Range("A1").Select
80
81 ActiveCellInTable = False
82 On Error Resume Next
83 ActiveCellInTable = (New_Ws.Range("A1").ListObject.Name <> "")
84 On Error GoTo 0
85
86 Application.ScreenUpdating = False
87
88 'If you do not create a table, you have the option to copy the formats.
89 If ActiveCellInTable = False Then
90 Application.GoTo ACell
91 CopyFormats = MsgBox("Do you also want to copy the Formats?", _
92 vbOKCancel + vbExclamation, "Copy to new worksheet")
93 If CopyFormats = vbOK Then
94 ACell.ListObject.Range.Copy
95 With New_Ws.Range("A1")
96 .PasteSpecial xlPasteFormats
97 Application.CutCopyMode = False
98 End With
99 End If
100 End If
101 End If
102
103 'Select the new worksheet if it is not active.
104 Application.GoTo New_Ws.Range("A1")
105
106 With Application
107 .ScreenUpdating = True
108 .EnableEvents = True
109 End With
110
111 Else
112 MsgBox "Select a cell in your list or table before you run the macro.", _
113 vbOKOnly, "Copy to new worksheet"
114 End If
115End Sub