title: Copy only selected table columns after filter to new worksheet
body: <p>How do I copy only selected table columns, after filtering, to a new worksheet.</p>
  
  <p>I already have code which after filtering, all table columns in old sheet also appear in the new worksheet. I want selected table columns to show in the new worksheet not all.</p>
  
  <p>Code that I copied from <a href="http://www.rondebruin.nl/" rel="nofollow noreferrer">http://www.rondebruin.nl/</a>.</p>
  
  <pre><code>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 &lt;&gt; "")
      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:="=" &amp; 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
  </code></pre>
  
  <p>Code for CopyListOrTable2NewWorksheet.</p>
  
  <pre><code>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 &lt;&gt; "")
      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 " &amp; _
                     "copy the visible data to a new worksheet. Tip: Sort your " &amp; _
                     "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 &gt; 0 Then
                  MsgBox "Change the name of sheet : " &amp; New_Ws.Name &amp; _
                       " manually after the macro is ready. The sheet name" &amp; _
                       " you fill in already exists or you use characters" &amp; _
                       " 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 &lt;&gt; "")
              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
  </code></pre>