Split table copy to new workbook

[Bl4ckSunr1se]

Hi,

I'm trying to create multiple tables from one master table. It concerns a training schedule where I want to extract lists per person. So the script should loop through the table and select each person and list their trainings.

I found code on the web, but it doesn't seem to work. I get an error 1004 on

Workbk.Sheets(sht).Range("I1:I" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

Characters do not exceed 30. The column that needs filtering is "I".

Thanks

Option Explicit

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook

'Specify sheet name in which the data is stored
sht = "Lijst"

'Workbook where VBA code resides
Set Workbk = ThisWorkbook

'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate

'change filter column in the following code
last = Workbk.Sheets(sht).Cells(Rows.Count, "I").End(xlUp).Row

With Workbk.Sheets(sht)
Set rng = .Range("A1:I" & last)
End With

Workbk.Sheets(sht).Range("I1:I" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

With rng
.AutoFilter
.AutoFilter Field:=9, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy

newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x

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

With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

End Sub

 

[Fluff]

Ok use this

   For Each Cl In Ws.Range("I2:I" & last)
      Dic(Cl.Value) = Empty
   Next Cl

 

[Bl4ckSunr1se]

YES!! works like a charm now! :D
Thanks

 

[Fluff]

Glad to help & thanks for the feedback.