在筛选到新的工作表后，只显示选定的表格列

我是Excel VBA的初学者。 我有问题，如何显示只有选定的表格列后筛选到一个新的工作表。 我已经有了过滤到新工作表后的代码，老工作表中的所有表列也显示并出现在新的工作表中，我只想select表列在新工作表中显示不是全部。 下面是我使用的代码，我从http://www.rondebruin.nl/复制。 我希望任何人都可以帮助我。 谢谢。

Sub FilterListOrTableData4AndCopyToWorksheet() Dim ACell As Range Dim ActiveCellInTable As Boolean Dim FilterCriteria As String If ActiveSheet.ProtectContents = True Then MsgBox "This macro is not working when the worksheet is protected", _ vbOKOnly, "Filter example" Exit Sub End If Set ACell = ActiveCell On Error Resume Next ActiveCellInTable = (ACell.ListObject.Name <> "") On Error GoTo 0 If ActiveCellInTable = True Then On Error Resume Next ActiveSheet.ShowAllData On Error GoTo 0 FilterCriteria = InputBox("What text do you want to filter on?", _ "Enter the filter item.") ACell.ListObject.Range.AutoFilter Field:=1, Criteria1:="=" & FilterCriteria Call CopyListOrTable2NewWorksheet Else MsgBox "Select a cell in your List or Table before you run the macro", _ vbOKOnly, "Filter example" End If End Sub 

这里是CopyListOrTable2NewWorksheet的代码。

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

如果ActiveWorkbook.ProtectStructure = True或ActiveSheet.ProtectContents = True MsgBox“当工作簿或工作表受保护时，此macros不起作用”Exit Sub End If

设置ACell = ActiveCell

On Error Resume Next ActiveCellInTable =（ACell.ListObject.Name <>“”）On Error GoTo 0

如果ActiveCellInTable = True那么

 With Application .ScreenUpdating = False .EnableEvents = False End With 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 ACell.ListObject.Range.Copy Set New_Ws = Worksheets.Add(after:=Sheets(ActiveSheet.Index)) 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 fill in already exists or you use characters" & _ " that are not allowed in a sheet name." Err.Clear End If On Error GoTo 0 With New_Ws.Range("A1") .PasteSpecial xlPasteColumnWidths .PasteSpecial xlPasteValuesAndNumberFormats .Select Application.CutCopyMode = False End With 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 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 Application.GoTo New_Ws.Range("A1") With Application .ScreenUpdating = True .EnableEvents = True End With 

否则MsgBox“在运行macros之前select您的列表或表中的单元格”，_ vbOKOnly，“复制到新的工作表”End If End Sub