过滤到新工作表后，仅显示选定的表列

我是Excel VBA的初学者 . 我有问题如何在筛选到新工作表后仅显示选定的表列 . 我已经有了过滤到新工作表之后的代码，旧表中的所有表列也显示并出现在新工作表中，我只想在新工作表中显示所选表格列而不是全部 . 下面是我使用的代码，我从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 Works 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“当工作簿或工作表受到保护时，此宏不起作用”退出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“在运行宏之前在列表或表中选择一个单元格”，_ vbOKOnly，“复制到新工作表”End If End Sub