EDIT FILTER VBA

[gleamng]

Good day all, i need some help with the macro below which autofilter column C to sheets from sheet1 that has data in column A, B & C.
in my case i want the vba to only copy column A&B only to sheets after filtering and also should not copy the heading. attached is screen shot of sheet1 (raw data) for clarification.

Option Explicit

Function GetWorksheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetWorksheet = Worksheets(shtName)
End Function

Sub Filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String
Dim LR As String
LR = Columns("C").Cells(Rows.Count, 1).End(xlUp).Offset(0, 0)

'specify sheet name in which the data is stored
sht = "Sheet1"

'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "C").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:C" & last)

Sheets(sht).Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AT1"), Unique:=True

For Each x In Range([AT2], Cells(Rows.Count, "AT").End(xlUp))
    If Not GetWorksheet(x.Text) Is Nothing Then
    Application.DisplayAlerts = False
    Sheets(x.Text).Delete
    Application.DisplayAlerts = True
    End If

With rng
    .AutoFilter
    .AutoFilter Field:=3, Criteria1:=x.Value
    .SpecialCells(xlCellTypeVisible).Copy
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
    ActiveSheet.Range("A1").Value = UCase(x.Value)
    ActiveSheet.Range("A2").PasteSpecial (xlPasteAll)
    Columns("A:B").EntireColumn.AutoFit
    Range("A1:B1").Select
    Range("A1:B1").HorizontalAlignment = xlCenter
    Selection.Merge
End With
Next x

'Turn off filter
Sheets(sht).AutoFilterMode = False

With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With
Sheet1.Activate
End Sub

 

[DanteAmor]

Here's another way to get the unique values, using a dictionary:
Note: Replace all your code with the following, the GetWorksheet function is no longer needed

Option Explicit

Sub Filter_v2()
  Dim sht As Worksheet
  Dim a As Variant, ky As Variant
  Dim rng As Range
  Dim dic As Object
  Dim i As Long
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sht = Sheets("Sheet1")    'specify sheet name in which the data is stored
  Set dic = CreateObject("Scripting.Dictionary")
  Set rng = sht.Range("A1:C" & sht.Cells(Rows.Count, "C").End(xlUp).Row)
  a = rng.Value
  
  For i = 2 To UBound(a, 1)
    dic(a(i, 3)) = Empty
  Next
  
  For Each ky In dic.keys
    On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
    
    rng.AutoFilter
    rng.AutoFilter Field:=3, Criteria1:=ky
    sht.AutoFilter.Range.Offset(1).Resize(, 2).Copy
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = ky
    Range("A1").Value = UCase(ky)
    Range("A2").PasteSpecial (xlPasteAll)
    Columns("A:B").EntireColumn.AutoFit
    Range("A1:B1").HorizontalAlignment = xlCenter
    Range("A1:B1").Merge
  Next
  
  'Turn off filter
  sht.Activate
  sht.AutoFilterMode = False
  
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

 

[gleamng]

Here's another way to get the unique values, using a dictionary:
Note: Replace all your code with the following, the GetWorksheet function is no longer needed

Option Explicit

Sub Filter_v2()
  Dim sht As Worksheet
  Dim a As Variant, ky As Variant
  Dim rng As Range
  Dim dic As Object
  Dim i As Long
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sht = Sheets("Sheet1")    'specify sheet name in which the data is stored
  Set dic = CreateObject("Scripting.Dictionary")
  Set rng = sht.Range("A1:C" & sht.Cells(Rows.Count, "C").End(xlUp).Row)
  a = rng.Value
 
  For i = 2 To UBound(a, 1)
    dic(a(i, 3)) = Empty
  Next
 
  For Each ky In dic.keys
    On Error Resume Next: Sheets(ky).Delete: On Error GoTo 0
   
    rng.AutoFilter
    rng.AutoFilter Field:=3, Criteria1:=ky
    sht.AutoFilter.Range.Offset(1).Resize(, 2).Copy
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = ky
    Range("A1").Value = UCase(ky)
    Range("A2").PasteSpecial (xlPasteAll)
    Columns("A:B").EntireColumn.AutoFit
    Range("A1:B1").HorizontalAlignment = xlCenter
    Range("A1:B1").Merge
  Next
 
  'Turn off filter
  sht.Activate
  sht.AutoFilterMode = False
 
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

Thanks a million, it work fine just as i wanted. However I want the generated sheets be saved as . XLS workbook files each and be saved to a location in drive c: