在筛选新工作表后，仅显示选定的表格列
我是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 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“当工作簿或工作表受保护时，此宏不起作用”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“在运行宏之前在列表或表中选择一个单元格”，_ vbOKOnly，“复制到新工作表”End If End Sub
链接地址: http://www.djcxy.com/p/38003.html上一篇: Show only selected table column after filter to new worksheets