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

[sekar]

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.,

 

[SanjayGMusafir]

The best way is to use record Macro action on Developer tab and develop a starting VBA code for yourself

Most of the times it works seamlessly.

And with your kind of requirement I think it should serve the purpose.

 

[Alex Blakenburg]

What version of Excel are you running ?
Please update your profile to show the version, solutions may vary depending on the version of Excel.

 

[SanjayGMusafir]

Excel 2010 (windows) - Probably he updated but forgot to mention that he has done that.

 

[Alex Blakenburg]

Thanks Sanjay, not what I was hoping for, thought I could use Unique but obviously not

 

[SanjayGMusafir]

This is what I once got from this forum to filter my records. Though I improvised it to my needs over the period. Rest copying and pasting you know coding better than I would ever know.

'To Filter Blank Records
    
    Dim x1 As Variant, x2 As Variant, x3 As Variant
    
    With ActiveSheet.ListObjects("Clients")
    
        x1 = Application.Match("BDay", .Range.Rows(1), 0)
        x2 = Application.Match("Mobile", .Range.Rows(1), 0)
        x3 = Application.Match("DOD", .Range.Rows(1), 0)
    
        If IsError(x1) Then Exit Sub
        If IsError(x2) Then Exit Sub
        If IsError(x3) Then Exit Sub
    
        ActiveSheet.ListObjects("Clients").Range.AutoFilter x1, "<>"
        ActiveSheet.ListObjects("Clients").Range.AutoFilter x2, "<>"
        ActiveSheet.ListObjects("Clients").Range.AutoFilter x3, "="
    
    End With

 

[Alex Blakenburg]

Give this a try:
It assumes you are not using an Excel Table. If you are using a table please advise the Sheet name and the Table name.

Sub FilterByMaterialCreateSheet()

    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
  
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationManual
     
    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))
            shtDest.Name = vKey
            ' Resize Columns widths
            shtSrc.Cells.Copy
            shtDest.Cells.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            ' Copy filtered data
            rngSrc.Copy Destination:=shtDest.Range("B1")
            Range("B1").Select
        End If
    Next vKey
  
    shtSrc.ShowAllData
    shtSrc.Activate
    shtSrc.Range("B1").Select
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

 

[sekar]

Hi Alex.,

The code throws debug error at the end pointing to the below line of code.

shtDest.Name = vKey

Also the output has not generated for the below filtered list.

Plank list for Ms.Jayashree - Non CG Radiance Pride B105.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
285	284	Master Bedroom	WR - 01/Wardrobe - 1150mm	Shutter	1998	573	1		Offwhite-11655 SF/21027 SF	-100P			Double colour laminate as per design
286	285	Master Bedroom	WR - 01/Wardrobe - 1150mm	Shutter	1998	573	1		Offwhite-11655 SF/21027 SF	-100P			Double colour laminate as per design
405	404	Bedroom 1	WR - 01/Wardrobe - 1000mm	Shutter	2008	498	1		Offwhite-11655 SF/21027 SF	-100P			Double colour laminate as per design
406	405	Bedroom 1	WR - 01/Wardrobe - 1000mm	Shutter	2008	498	1		Offwhite-11655 SF/21027 SF	-100P			Double colour laminate as per design
Data

 

[Alex Blakenburg]

It probably means that sheet already exists. What do you want the macro to do if that happens. Can it delete the sheet ?

Another possibility is that you have characters that are not allowed in a sheet name.

 

[sekar]

It probably means that sheet already exists. What do you want the macro to do if that happens. Can it delete the sheet ?

Another possibility is that you have characters that are not allowed in a sheet name.

yes, the slash ( / ) is the culprit.
yes the macro can delete the sheet.
Also the last set of filtered values not pasted in to the created sheet. (error: less memory for completing the task). debug at

shtDest.Cells.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False

Can i transfer the file through we transfer to check?