Change filtered column in VBA macro - excel

Question

I've seen a macro here that works well for filtering and copying data into a new tab. However, it doesn't work when I try to change the filtered column (in this case is column F, but I want to change to column B). See below:
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
'specify sheet name in which the data is stored
sht = "Sheet1"
'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:F" & last)
Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=6, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x
' Turn off filter
Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub

Answer 1

I'd say if you want this to be re-usable for different sheets then one more layer of abstraction would be useful, so you can call the same sub but with different source ranges:
Sub Tester()
With ThisWorkbook.Worksheets("Sheet1")
FilterRangeToNewSheets .Range("A1:F" & .Cells(.Rows.Count, "F").End(xlUp).Row), 6
End With
End Sub
'Given a range and a column index in that range, add new sheets, one for each
' set of unique values in the range
Sub FilterRangeToNewSheets(rngToFilter As Range, filterColumnIndex As Long)
Dim vals As Collection, k, wb As Workbook
Set wb = rngToFilter.Worksheet.Parent 'parent workbook
Set vals = Uniques(rngToFilter.Columns(filterColumnIndex).Offset(1, 0)) 'offset to exclude the header
For Each k In vals
With rngToFilter
.AutoFilter
.AutoFilter Field:=filterColumnIndex, Criteria1:=k
.SpecialCells(xlCellTypeVisible).Copy
With wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
.Name = k
.Paste Destination:=.Range("A1")
End With
End With
Next k
rngToFilter.Worksheet.AutoFilterMode = False ' Turn off filter
Application.CutCopyMode = False
End Sub
'extract all unique values from a range into a dictionary
Function Uniques(rng As Range) As Collection
Dim col As New Collection, data, c As Range, v
For Each c In rng.Cells
v = c.Value
If Len(v) > 0 Then
On Error Resume Next 'ignore any duplicate key error
col.Add v, v
On Error GoTo 0 'stop ignoring errors
End If
Next c
Set Uniques = col
End Function
Swapped out your Advanced Filter for a function which will return a Collection containing only unique values.