过滤后，如何仅将选定的表列复制到新工作表中。
我已经有代码，过滤后，旧表中的所有表列也会出现在新工作表中。我希望选定的表列不全部显示在新工作表中。
我从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
最佳答案
我建议你更换
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的更多详细信息）