Show only selected table column after filter to new worksheets

I'm a beginner in Excel VBA. I have problem with how to show only selected table column after been filter to a new worksheets. I already have code which after filter to new worksheet, all table column in old sheet also show and appear in new worksheets, I just want selected table column to show in new worksheets not all. Below is code that I used that I copy from http://www.rondebruin.nl/. I hope anyone can help me. Thank you.

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

here the code for 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

If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then MsgBox "This macro is not working when the workbook or worksheet is protected" Exit Sub End If

Set ACell = ActiveCell

On Error Resume Next ActiveCellInTable = (ACell.ListObject.Name <> "") On Error GoTo 0

If ActiveCellInTable = True Then

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

Else MsgBox "Select a cell in your List or Table before you run the macro", _ vbOKOnly, "Copy to new worksheet" End If End Sub

链接地址: http://www.djcxy.com/p/38004.html

上一篇: 如何点击一个超链接（aspx页面）并保存

下一篇: 在筛选新工作表后，仅显示选定的表格列