Auto filter - filter each values (First, second, third) in the column

S

sekar

New Member
Joined
Feb 2, 2009
Messages
33
Office Version
  1. 2010
Platform
  1. Windows
Hi.,

I want to filter the data in the column I, each value (First value (16mm BWR Ply wood), second value (16mm HDHMR), third value (3.5mm BWR plywood) ) has to be filtered out one by one (i.e seperately) and corresponding filtered output has to be copied to a new sheet with name as filtered ( First sheet (16mm HDHMR), second sheet(16mm HDHMR), third sheet (3.5mm BWR plywood), etc.,) using the excel vba.


Thanks.,
 

Attachments

  • Screenshot (4).png
    Screenshot (4).png
    94.1 KB · Views: 10
Sort by date Sort by votes
If that is a file sharing platform that let's you post a link here, then sure.
What do you want to do if the product has a "/" in the name ?
If column autofit is good enough for you I can get rid of the pastespecial column widths causing the memory issue.
 
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Here is a version that does uses Columns.Autofit instead of the xlPasteColumnWidths and replaces any illegal sheet name characters with a "|" (pipe) symbol and deletes the sheet if it already exists.

VBA Code: 
Sub FilterByMaterialCreateSheet_v02()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim rngSrc As Range, arrSrc As Variant
    Dim lrowSrc As Long, lcolSrc As Long, colSrcFltr As Long
    Dim dictMaterial As Object, dictKey As String, vKey As Variant
    Dim i As Long
    Dim sName As String
    Dim illegalNmChar As Variant
    Dim replaceNmChr As String
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    illegalNmChar = Array("/", "\", "[", "]", "*", "?", ":")
    replaceNmChr = "|"
       
    Set shtSrc = Worksheets("Data")                                         ' <--- Change to your sheet name
    With shtSrc
        lrowSrc = .Cells(Rows.Count, "I").End(xlUp).Row
        lcolSrc = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set rngSrc = .Range(.Cells(1, "B"), .Cells(lrowSrc, lcolSrc))
        arrSrc = rngSrc
        colSrcFltr = .Columns("I").Column - rngSrc.Cells(1).Column + 1      ' <--- Column letter to use for filtering
    End With
    
    Set dictMaterial = CreateObject("Scripting.dictionary")
    
    ' Load unique materials into Dictionary
    For i = 2 To UBound(arrSrc)
        dictKey = arrSrc(i, colSrcFltr)
        If Not dictMaterial.exists(dictKey) And dictKey <> "" Then
            dictMaterial(dictKey) = i
        End If
    Next i
    
    If shtSrc.FilterMode Then shtSrc.ShowAllData

    For Each vKey In dictMaterial.keys
        rngSrc.AutoFilter Field:=colSrcFltr, Criteria1:=vKey
        If rngSrc.SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set shtDest = Worksheets.Add(After:=Sheets(Sheets.Count))
            On Error Resume Next
                shtDest.Name = vKey
                If Err <> 0 Then
                    If InStr(1, Err.Description, "taken", vbTextCompare) > 0 Then
                        Application.DisplayAlerts = False
                        Worksheets(vKey).Delete
                        Application.DisplayAlerts = True
                        shtDest.Name = vKey
                    ElseIf Len(vKey) > 31 Then
                        shtDest.Name = Left(vKey, 31)
                    Else
                        sName = vKey
                        For i = 0 To UBound(illegalNmChar)
                            sName = Replace(sName, illegalNmChar(i), replaceNmChr)
                        Next i
                        shtDest.Name = sName
                    End If
                End If
            On Error GoTo 0

            ' Copy filtered data
            rngSrc.Copy Destination:=shtDest.Range("B1")
            ' Resize Columns widths
            shtDest.UsedRange.EntireColumn.AutoFit
            Range("B1").Select
        End If
    Next vKey
    
    shtSrc.ShowAllData
    shtSrc.Activate
    shtSrc.Range("B1").Select
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
 
Upvote 0
Alex Blakenburg said:
Here is a version that does uses Columns.Autofit instead of the xlPasteColumnWidths and replaces any illegal sheet name characters with a "|" (pipe) symbol and deletes the sheet if it already exists.

VBA Code: 
Sub FilterByMaterialCreateSheet_v02()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim rngSrc As Range, arrSrc As Variant
    Dim lrowSrc As Long, lcolSrc As Long, colSrcFltr As Long
    Dim dictMaterial As Object, dictKey As String, vKey As Variant
    Dim i As Long
    Dim sName As String
    Dim illegalNmChar As Variant
    Dim replaceNmChr As String
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    illegalNmChar = Array("/", "\", "[", "]", "*", "?", ":")
    replaceNmChr = "|"
      
    Set shtSrc = Worksheets("Data")                                         ' <--- Change to your sheet name
    With shtSrc
        lrowSrc = .Cells(Rows.Count, "I").End(xlUp).Row
        lcolSrc = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set rngSrc = .Range(.Cells(1, "B"), .Cells(lrowSrc, lcolSrc))
        arrSrc = rngSrc
        colSrcFltr = .Columns("I").Column - rngSrc.Cells(1).Column + 1      ' <--- Column letter to use for filtering
    End With
   
    Set dictMaterial = CreateObject("Scripting.dictionary")
   
    ' Load unique materials into Dictionary
    For i = 2 To UBound(arrSrc)
        dictKey = arrSrc(i, colSrcFltr)
        If Not dictMaterial.exists(dictKey) And dictKey <> "" Then
            dictMaterial(dictKey) = i
        End If
    Next i
   
    If shtSrc.FilterMode Then shtSrc.ShowAllData

    For Each vKey In dictMaterial.keys
        rngSrc.AutoFilter Field:=colSrcFltr, Criteria1:=vKey
        If rngSrc.SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set shtDest = Worksheets.Add(After:=Sheets(Sheets.Count))
            On Error Resume Next
                shtDest.Name = vKey
                If Err <> 0 Then
                    If InStr(1, Err.Description, "taken", vbTextCompare) > 0 Then
                        Application.DisplayAlerts = False
                        Worksheets(vKey).Delete
                        Application.DisplayAlerts = True
                        shtDest.Name = vKey
                    ElseIf Len(vKey) > 31 Then
                        shtDest.Name = Left(vKey, 31)
                    Else
                        sName = vKey
                        For i = 0 To UBound(illegalNmChar)
                            sName = Replace(sName, illegalNmChar(i), replaceNmChr)
                        Next i
                        shtDest.Name = sName
                    End If
                End If
            On Error GoTo 0

            ' Copy filtered data
            rngSrc.Copy Destination:=shtDest.Range("B1")
            ' Resize Columns widths
            shtDest.UsedRange.EntireColumn.AutoFit
            Range("B1").Select
        End If
    Next vKey
   
    shtSrc.ShowAllData
    shtSrc.Activate
    shtSrc.Range("B1").Select
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
Click to expand...

Thanks Alex. This works like as charm.,

Suppose if i have a header for six rows, which has to be copied to all the sheets, what i have to change. Also the sl.no has to be inserted in the Column A as similar like Data sheet.

Attached the link of the file

reference file link

Thanks
 
Upvote 0
Give this a try:
VBA Code: 
Sub FilterByMaterialCreateSheet_v02()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim rngSrc As Range, arrSrc As Variant
    Dim lrowSrc As Long, lcolSrc As Long, colSrcFltr As Long
    Dim dictMaterial As Object, dictKey As String, vKey As Variant
    Dim i As Long
    Dim sName As String
    Dim illegalNmChar As Variant
    Dim replaceNmChr As String
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    illegalNmChar = Array("/", "\", "[", "]", "*", "?", ":")
    replaceNmChr = "|"
       
    Set shtSrc = Worksheets("Data")                                         ' <--- Change to your sheet name
    With shtSrc
        lrowSrc = .Cells(Rows.Count, "I").End(xlUp).Row
        lcolSrc = .Cells(6, Columns.Count).End(xlToLeft).Column
        Set rngSrc = .Range(.Cells(6, "A"), .Cells(lrowSrc, lcolSrc))
        arrSrc = rngSrc
        colSrcFltr = .Columns("I").Column - rngSrc.Cells(1).Column + 1      ' <--- Column letter to use for filtering
    End With
    
    Set dictMaterial = CreateObject("Scripting.dictionary")
    
    ' Load unique materials into Dictionary
    For i = 2 To UBound(arrSrc)
        dictKey = arrSrc(i, colSrcFltr)
        If Not dictMaterial.exists(dictKey) And dictKey <> "" Then
            dictMaterial(dictKey) = i
        End If
    Next i
    
    If shtSrc.AutoFilterMode Then shtSrc.AutoFilterMode = False

    For Each vKey In dictMaterial.keys
        rngSrc.AutoFilter Field:=colSrcFltr, Criteria1:=vKey
        If rngSrc.SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set shtDest = Worksheets.Add(After:=Sheets(Sheets.Count))
            On Error Resume Next
                shtDest.Name = vKey
                If Err <> 0 Then
                    If InStr(1, Err.Description, "taken", vbTextCompare) > 0 Then
                        Application.DisplayAlerts = False
                        Worksheets(vKey).Delete
                        Application.DisplayAlerts = True
                        shtDest.Name = vKey
                    ElseIf Len(vKey) > 31 Then
                        shtDest.Name = Left(vKey, 31)
                    Else
                        sName = vKey
                        For i = 0 To UBound(illegalNmChar)
                            sName = Replace(sName, illegalNmChar(i), replaceNmChr)
                        Next i
                        shtDest.Name = sName
                    End If
                End If
            On Error GoTo 0

            ' Copy in heading rows and resize column widths
            shtSrc.Rows("1:5").Copy
            shtDest.Rows("1:5").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            shtDest.Rows("1:5").PasteSpecial Paste:=xlPasteAll
            
            ' Copy filtered data
            rngSrc.Copy Destination:=shtDest.Range("A6")
       
            shtDest.Activate
            shtDest.Range("A1").Select
        End If
    Next vKey
    
    shtSrc.ShowAllData
    shtSrc.Activate
    shtSrc.Range("A1").Select
    
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
 
Upvote 0
Solution
Alex Blakenburg said:
Give this a try:
VBA Code: 
Sub FilterByMaterialCreateSheet_v02()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim rngSrc As Range, arrSrc As Variant
    Dim lrowSrc As Long, lcolSrc As Long, colSrcFltr As Long
    Dim dictMaterial As Object, dictKey As String, vKey As Variant
    Dim i As Long
    Dim sName As String
    Dim illegalNmChar As Variant
    Dim replaceNmChr As String
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    illegalNmChar = Array("/", "\", "[", "]", "*", "?", ":")
    replaceNmChr = "|"
      
    Set shtSrc = Worksheets("Data")                                         ' <--- Change to your sheet name
    With shtSrc
        lrowSrc = .Cells(Rows.Count, "I").End(xlUp).Row
        lcolSrc = .Cells(6, Columns.Count).End(xlToLeft).Column
        Set rngSrc = .Range(.Cells(6, "A"), .Cells(lrowSrc, lcolSrc))
        arrSrc = rngSrc
        colSrcFltr = .Columns("I").Column - rngSrc.Cells(1).Column + 1      ' <--- Column letter to use for filtering
    End With
   
    Set dictMaterial = CreateObject("Scripting.dictionary")
   
    ' Load unique materials into Dictionary
    For i = 2 To UBound(arrSrc)
        dictKey = arrSrc(i, colSrcFltr)
        If Not dictMaterial.exists(dictKey) And dictKey <> "" Then
            dictMaterial(dictKey) = i
        End If
    Next i
   
    If shtSrc.AutoFilterMode Then shtSrc.AutoFilterMode = False

    For Each vKey In dictMaterial.keys
        rngSrc.AutoFilter Field:=colSrcFltr, Criteria1:=vKey
        If rngSrc.SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set shtDest = Worksheets.Add(After:=Sheets(Sheets.Count))
            On Error Resume Next
                shtDest.Name = vKey
                If Err <> 0 Then
                    If InStr(1, Err.Description, "taken", vbTextCompare) > 0 Then
                        Application.DisplayAlerts = False
                        Worksheets(vKey).Delete
                        Application.DisplayAlerts = True
                        shtDest.Name = vKey
                    ElseIf Len(vKey) > 31 Then
                        shtDest.Name = Left(vKey, 31)
                    Else
                        sName = vKey
                        For i = 0 To UBound(illegalNmChar)
                            sName = Replace(sName, illegalNmChar(i), replaceNmChr)
                        Next i
                        shtDest.Name = sName
                    End If
                End If
            On Error GoTo 0

            ' Copy in heading rows and resize column widths
            shtSrc.Rows("1:5").Copy
            shtDest.Rows("1:5").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            shtDest.Rows("1:5").PasteSpecial Paste:=xlPasteAll
           
            ' Copy filtered data
            rngSrc.Copy Destination:=shtDest.Range("A6")
      
            shtDest.Activate
            shtDest.Range("A1").Select
        End If
    Next vKey
   
    shtSrc.ShowAllData
    shtSrc.Activate
    shtSrc.Range("A1").Select
   
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
Click to expand...
Dear Alex,

I am actually trying to do something similar, instead of one thing that was slightly different.

Taking sekar's example.

If I would like to first filter column D - "Bottom_Panel" and then I want to filter Column I, one by one that is listed in Column I after filtering column D, and export them as different sheets.

How should I begin with?

I have tried to look into the code and adding this function in, but this seems too advanced for me. Appreciate if you could help.
 
Upvote 0
Alex Blakenburg said:
Give this a try:
VBA Code: 
Sub FilterByMaterialCreateSheet_v02()

    Dim shtSrc As Worksheet, shtDest As Worksheet
    Dim rngSrc As Range, arrSrc As Variant
    Dim lrowSrc As Long, lcolSrc As Long, colSrcFltr As Long
    Dim dictMaterial As Object, dictKey As String, vKey As Variant
    Dim i As Long
    Dim sName As String
    Dim illegalNmChar As Variant
    Dim replaceNmChr As String
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    illegalNmChar = Array("/", "\", "[", "]", "*", "?", ":")
    replaceNmChr = "|"
      
    Set shtSrc = Worksheets("Data")                                         ' <--- Change to your sheet name
    With shtSrc
        lrowSrc = .Cells(Rows.Count, "I").End(xlUp).Row
        lcolSrc = .Cells(6, Columns.Count).End(xlToLeft).Column
        Set rngSrc = .Range(.Cells(6, "A"), .Cells(lrowSrc, lcolSrc))
        arrSrc = rngSrc
        colSrcFltr = .Columns("I").Column - rngSrc.Cells(1).Column + 1      ' <--- Column letter to use for filtering
    End With
   
    Set dictMaterial = CreateObject("Scripting.dictionary")
   
    ' Load unique materials into Dictionary
    For i = 2 To UBound(arrSrc)
        dictKey = arrSrc(i, colSrcFltr)
        If Not dictMaterial.exists(dictKey) And dictKey <> "" Then
            dictMaterial(dictKey) = i
        End If
    Next i
   
    If shtSrc.AutoFilterMode Then shtSrc.AutoFilterMode = False

    For Each vKey In dictMaterial.keys
        rngSrc.AutoFilter Field:=colSrcFltr, Criteria1:=vKey
        If rngSrc.SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set shtDest = Worksheets.Add(After:=Sheets(Sheets.Count))
            On Error Resume Next
                shtDest.Name = vKey
                If Err <> 0 Then
                    If InStr(1, Err.Description, "taken", vbTextCompare) > 0 Then
                        Application.DisplayAlerts = False
                        Worksheets(vKey).Delete
                        Application.DisplayAlerts = True
                        shtDest.Name = vKey
                    ElseIf Len(vKey) > 31 Then
                        shtDest.Name = Left(vKey, 31)
                    Else
                        sName = vKey
                        For i = 0 To UBound(illegalNmChar)
                            sName = Replace(sName, illegalNmChar(i), replaceNmChr)
                        Next i
                        shtDest.Name = sName
                    End If
                End If
            On Error GoTo 0

            ' Copy in heading rows and resize column widths
            shtSrc.Rows("1:5").Copy
            shtDest.Rows("1:5").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            shtDest.Rows("1:5").PasteSpecial Paste:=xlPasteAll
           
            ' Copy filtered data
            rngSrc.Copy Destination:=shtDest.Range("A6")
      
            shtDest.Activate
            shtDest.Range("A1").Select
        End If
    Next vKey
   
    shtSrc.ShowAllData
    shtSrc.Activate
    shtSrc.Range("A1").Select
   
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
Click to expand...
Sorry just one more question..

I am able to find my desired column and create individual worksheets uniquely named.

But it is not filtering and copying what I need to the new worksheet.

All the new worksheets are blank

I have my data from A1 to AX35

The column that i needed to filter and create new sheets are Column C

And what i need to filter first before I filter column C is Column R (Filter Value = Today)


So to summarize.

I need to first filter Column R as today -> based on the filtered results i need to individually filter Column C, copy and paste the filtered data into a new sheet.


Thanks!
 
Upvote 0
@keiar Welcome to the Forum.
I'm afraid you will need to create a new thread for your question and provide details of your requirements ideally providing an XL2BB sample of your data so that people helping have some data to work with.

Using XL2BB
MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
Compiling different structures from an organisational structure
Replies
1
Views
65
Buks69
B
A
  • Question
Dynamically add new rows via VBA when using IFERROR TEXTJOIN and FILTER formulas from Table?
Replies
0
Views
81
AlfredDB
A
O
  • Question
Printing multiple times with changing data
Replies
1
Views
228
orzys
O
C
  • Question
VBA Copy Sort
Replies
4
Views
138
Keebler
Keebler
S
  • Question
Xlookup on multiple columns Filtering
Replies
2
Views
166
scottishbigyin
S

Forum statistics

Threads
1,215,024
Messages
6,122,729
Members
449,093
Latest member
Mnur

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top