excel - 仅将筛选后选定的表格列复制到新工作表

Question

如何在过滤后仅将选定的表格列复制到新工作表。

我已经有代码，在过滤后，旧工作表中的所有表列也会出现在新工作表中。我希望选定的表格列显示在新工作表中，而不是全部。

我从 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

    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

Answer 1

建议你更换

ACell.ListObject.Range.Copy

与

ACell.ListObject.ListColumns(1).Range.Copy

仅复制第一列，

ACell.ListObject.ListColumns(1).DataBodyRange.Copy

仅选择第一列中的数据，

ACell.ListObject.ListColumns(1).DataBodyRange.Resize(, 3).Copy

仅选择第一、第二和第三列中的数据

(有关 https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables 的更多详细信息)