Tech Support Guy banner
Status
Not open for further replies.

show only selected column after filter to new worksheets

Solved 
Tags
columns table
5K views 57 replies 2 participants last post by  Keebellah 
#1 ·
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
 
See less See more
#37 ·
And, does it work?
Is the Excel file on a network drive or on a local drive?
Have you checked the trusted locations?
Like I said it works here so I cannot tell you why it will not work for you.
You will have to take the time and check all options.
What happens if you run the macro directly from the VBA editor?
Or Open Developer tab and select the macro showUserform to run
 
#38 ·
this is SelectvalueFrm code. is there something wrong with the code?
Code:
Dim Tbl     As ListObject
Dim ws      As Worksheet
Dim tCol    As Integer

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub UserForm_Activate()
Me.Top = Application.Top + (Me.Height)
Me.Left = Application.Width - (Me.Width + 50)
Me.Caption = "HC&TS,2017"
End Sub

Private Sub UserForm_Initialize()
Set ws = Worksheets("Sheet1")
Set Tbl = ws.ListObjects("Table1")
With CBoxList
    .Clear
    For tCol = 1 To Tbl.ListColumns.Count
        If InStr(1, "name|branch|department|lmws", LCase(Tbl.Range(1, tCol).Text)) = 0 Then .AddItem Tbl.Range(1, tCol).Text
    Next tCol
End With
End Sub
 
Private Sub CBoxList_Change()
'*
End Sub

Private Sub CommandButton1_Click()
If Me.CBoxList.Value = "" Then Exit Sub

End Sub
 
#39 ·
and this is CopyWorksheetModule code.
Code:
Public Sub showUserform()
Worksheets("Sheet1").Activate
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
    MsgBox "This macro is not working when the workbook or worksheet is protected!", _
        vbExclamation, "Copy to new worksheet"
    Exit Sub
End If
Load SelectValuefrm
SelectValuefrm.Show
End Sub

Sub Copy_To_Worksheets(myField As String)
Worksheets("Sheet1").Activate
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
    MsgBox "This macro is not working when the workbook or worksheet is protected!", _
        vbExclamation, "Copy to new worksheet"
    Exit Sub
End If
    
    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

    Set rng = Nothing
    
    Set My_Table = ActiveSheet.ListObjects("Table1")
    With Range(My_Table.HeaderRowRange.Address)
        Set rng = .Find(What:=myField, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
        If Not rng Is Nothing Then rng.Select
    End With
    
    If rng Is Nothing Then
        MsgBox "The requested value '" & myField & "' is not present in " & My_Table.Name, vbExclamation, ""
        Exit Sub
    End If
    
    FieldNum = rng.Column - My_Table.Range.Cells(1).Column + 1

    '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
    Set rng = ActiveCell
    'Test if rng is in a a list or Table
    ActiveCellInTable = (rng.ListObject.Name <> "")
    'If the cell is in a List or Table run the code
    If ActiveCellInTable = True Then


        '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)
                If Len(Trim(cell.Value)) > 0 Then
                    '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
                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."
        Else
            '*  This section will be excecuted if no error was triggered
            '*  all columns but the four requested remain visible
            
            Dim Lcol        As Long
            WSNew.Activate
            Lcol = Cells(1, Columns.Count).End(xlToLeft).Column
            Set rng = WSNew.Range(Cells(1, 1), Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column))
            rng.Columns.Hidden = False
            For CCount = Lcol To 1 Step -1
                If InStr(1, "name|branch|department|lmws", LCase(Cells(1, CCount).Text)) = 0 Then Cells(1, CCount).EntireColumn.Delete
            Next CCount
            Range("A2").Select
        End If

        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
 
#40 ·
The code is correct. If this is the exact code that was in the file I attached then there is no problem it works.
The problem is with your system or settings.
Why are you showing the VBA code anyway, I know the version I sent you works fine unless you changed things like worksheets and so
 
#41 ·
Just to be sure here is the VBA code AGAIN:

This is for the Userform

Code:
Option Explicit
Dim Tbl     As ListObject
Dim ws      As Worksheet
Dim tCol    As Integer

Private Sub UserForm_Activate()
With Me
    .Top = Application.Top + (Me.Height)
    .Left = Application.Width - (Me.Width + 50)
    .Caption = "HC&TS,2017"
    .CommandButton1.Visible = False
    .CommandButton2.Caption = "Cancel/Exit"
End With
End Sub

Private Sub UserForm_Initialize()
Set ws = Worksheets(mySheetName)
Set Tbl = ws.ListObjects(myTableName)
With CBoxList
    .Clear
    For tCol = 1 To Tbl.ListColumns.Count
        If InStr(1, "name|branch|department|lmws", LCase(Tbl.Range(1, tCol).Text)) = 0 Then .AddItem Tbl.Range(1, tCol).Text
    Next tCol
End With
End Sub

Private Sub CBoxList_Change()
'*
Me.CommandButton1.Visible = Me.CBoxList.Value <> ""
If Me.CBoxList.Value = "" Then Exit Sub
With Me.CommandButton1
    .Caption = Me.CBoxList.Value
    .SetFocus
    .ControlTipText = "Press to proceed and process " & Me.CBoxList.Value
End With
End Sub

Private Sub CommandButton1_Click()
If Me.CBoxList.Value = "" Then Exit Sub
Copy_To_Worksheets myField:=Me.CBoxList.Text
Worksheets(mySheetName).Activate
CommandButton2_Click
End Sub

Private Sub CommandButton2_Click()
Me.CommandButton1.Visible = False
If Me.CBoxList.Value <> "" Then Me.CBoxList.Value = "": Exit Sub
Unload Me
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' This is to force the user to use the Cnacel button
    If CloseMode = vbFormControlMenu Then
        Cancel = True
    End If
    CommandButton2.SetFocus
End Sub
This is the VBA module for the actual work
Code:
Option Explicit

Global Const myTableName    As String = "Table1"
Global Const mySheetName    As String = "Sheet1"

Public Sub showUserform()
Worksheets(mySheetName).Activate
Range("C2").Select
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
    MsgBox "This macro is not working when the workbook or worksheet is protected!", _
        vbExclamation, "Copy to new worksheet"
    Exit Sub
End If
Load SelectValuefrm
SelectValuefrm.Show
Worksheets(mySheetName).Activate
Range("C2").Select
End Sub

Public Sub Copy_To_Worksheets(myField As String)
Worksheets(mySheetName).Activate
If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
    MsgBox "This macro is not working when the workbook or worksheet is protected!", _
        vbExclamation, "Copy to new worksheet"
    Exit Sub
End If
   
    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

    On Error Resume Next
    Set WSNew = Nothing
    Set WSNew = Worksheets(myField)
    Err.Clear
    On Error GoTo 0
    If Not WSNew Is Nothing Then
        Select Case MsgBox("'" & myField & "' has already been processed!" & vbCrLf & vbCrLf & _
            "Press 'OK' to continue, 'Cancel' to Stop", vbExclamation + vbOKCancel + vbDefaultButton2, _
            "'OK' to process again!" & Space(10) & "HC&TS,2017")
        Case Is = vbOK
            Application.DisplayAlerts = False
            WSNew.Delete
        Case Else
            Exit Sub
        End Select
    End If
    Application.DisplayAlerts = True

    Set rng = Nothing
   
    Set My_Table = ActiveSheet.ListObjects(myTableName)
    With Range(My_Table.HeaderRowRange.Address)
        Set rng = .Find(What:=myField, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
        If Not rng Is Nothing Then rng.Select
    End With
   
    If rng Is Nothing Then
        MsgBox "The requested value '" & myField & "' is not present in " & My_Table.Name, vbExclamation, ""
        Exit Sub
    End If
   
    FieldNum = rng.Column - My_Table.Range.Cells(1).Column + 1

    '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
    Set rng = ActiveCell
    'Test if rng is in a a list or Table
    ActiveCellInTable = (rng.ListObject.Name <> "")
    'If the cell is in a List or Table run the code
    If ActiveCellInTable = True Then


        '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)
                If Len(Trim(cell.Value)) > 0 Then
                    '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
                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."
        Else
            '*  This section will be excecuted if no error was triggered
            '*  all columns but the four requested remain visible
           
            Dim Lcol        As Long
            WSNew.Activate
            Lcol = Cells(1, Columns.Count).End(xlToLeft).Column
            Set rng = WSNew.Range(Cells(1, 1), Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column))
            rng.Columns.Hidden = False
            For CCount = Lcol To 1 Step -1
                If InStr(1, "name|branch|department|lmws", LCase(Cells(1, CCount).Text)) = 0 Then Cells(1, CCount).EntireColumn.Delete
            Next CCount
            Range("A2").Select
        End If

        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
 
#48 ·
Hi Keebellah,

I need your help again. There are some changes of my data in table. It looks like this:

Font Parallel Rectangle Slope Screenshot


so with using your given code, I want that when click that button the result will be like this:

Font Parallel Rectangle Number Pattern


I already try this with your code. But the result data under RADAR column been split to different new sheet. like this:

Rectangle Line Font Parallel Pattern


can you help me with this? With part in your given code need to be change? I really need your help. Thank you again. Here I attach the sample file.
 

Attachments

#52 ·
Hi Keebellah, I used your code in my sheets, but after click that button its showed cells with value and also blank cells. How about after click button, it only showed cells with values only. for example, it only showed cells with values under RADAR column.
 
#53 ·
The I guess you must explain yourself better.
The first time all was well but RADAR was not okay.
Please try your best and explain it in such a manner that the reader (me in this case) understands what you really require/want.
First you say it's working fine then you come with modifications and exceptions.
 
#55 ·
Sorry for the bad explanation from me. there some mistake in my modification. there are some of the cells is blank like this:
Font Rectangle Parallel Screenshot Number


so after click the button, it only copy/showed the cells with value like this:
Font Material property Rectangle Pattern Parallel


can you help me? I'm so sorry for my mistake and bad explanation. thank you so much for your help.
 

Attachments

Status
Not open for further replies.
You have insufficient privileges to reply here.
Top