Hi, I'm really new to excel macro and VBA. I need help on how to show only selected column after filter to new worksheets? I use this code by http://www.rondebruin.nl/ . In this code after done filter and copy data of specific value to new sheet, the table on new sheet show all column same as previous sheet. so my problem is how to only show selected column not all column on new sheet?
below is code that I been used.
Sub Copy_To_Worksheets1()
Dim CalcMode As Long
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FieldNum As Long
Dim My_Table As ListObject
Dim ErrNum As Long
Dim ActiveCellInTable As Boolean
Dim CCount As Long
'Select a cell in the column that you want to filter in the List or Table
'Or use this line if you want to select the cell that you want with code.
'In this example I select a cell in the Gender column
'Remove this line if you want to use the activecell column
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro is not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
Set rng = ActiveCell
'Test if rng is in a a list or Table
On Error Resume Next
ActiveCellInTable = (rng.ListObject.Name <> "")
On Error GoTo 0
'If the cell is in a List or Table run the code
If ActiveCellInTable = True Then
Set My_Table = rng.ListObject
FieldNum = rng.Column - My_Table.Range.Cells(1).Column + 1
'Show all data in the Table/List
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add
With ws2
'first we copy the Unique data from the filter field to ws2
My_Table.ListColumns(FieldNum).Range.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)
'Filter the range
My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
CCount = 0
On Error Resume Next
CCount = My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data to a new worksheet." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
Set WSNew = Worksheets.Add(after:=Sheets(Sheets.Count))
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
ErrNum = ErrNum + 1
WSNew.Name = "Error_" & Format(ErrNum, "0000")
Err.Clear
End If
On Error GoTo 0
'Copy the visible data and use PasteSpecial to paste to the new worksheet
My_Table.Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
End If
'Show all data in the Table/List
My_Table.Range.AutoFilter Field:=FieldNum
Next cell
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
If ErrNum > 0 Then MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" & vbNewLine & _
"There are characters in the Unique name that are not allowed in a sheet name or the sheet exist."
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
Else
MsgBox "Select a cell in the column of the List or Table that you want to filter"
End If
End Sub
below is code that I been used.
Sub Copy_To_Worksheets1()
Dim CalcMode As Long
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FieldNum As Long
Dim My_Table As ListObject
Dim ErrNum As Long
Dim ActiveCellInTable As Boolean
Dim CCount As Long
'Select a cell in the column that you want to filter in the List or Table
'Or use this line if you want to select the cell that you want with code.
'In this example I select a cell in the Gender column
'Remove this line if you want to use the activecell column
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro is not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
Set rng = ActiveCell
'Test if rng is in a a list or Table
On Error Resume Next
ActiveCellInTable = (rng.ListObject.Name <> "")
On Error GoTo 0
'If the cell is in a List or Table run the code
If ActiveCellInTable = True Then
Set My_Table = rng.ListObject
FieldNum = rng.Column - My_Table.Range.Cells(1).Column + 1
'Show all data in the Table/List
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add
With ws2
'first we copy the Unique data from the filter field to ws2
My_Table.ListColumns(FieldNum).Range.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)
'Filter the range
My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
CCount = 0
On Error Resume Next
CCount = My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data to a new worksheet." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
Set WSNew = Worksheets.Add(after:=Sheets(Sheets.Count))
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
ErrNum = ErrNum + 1
WSNew.Name = "Error_" & Format(ErrNum, "0000")
Err.Clear
End If
On Error GoTo 0
'Copy the visible data and use PasteSpecial to paste to the new worksheet
My_Table.Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
End If
'Show all data in the Table/List
My_Table.Range.AutoFilter Field:=FieldNum
Next cell
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
If ErrNum > 0 Then MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" & vbNewLine & _
"There are characters in the Unique name that are not allowed in a sheet name or the sheet exist."
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
Else
MsgBox "Select a cell in the column of the List or Table that you want to filter"
End If
End Sub