VBA code to Create Seperate Workbooks Auto Filter Error

[FredSams]

Hello everyone,

I found this script on a video and entered into excel. What I'm looking at is to take my customers items copy that data and create a new workbook with that data and would like to copy the header row into each sheet. The script I have asks you to Pick the column to sort and use as for the data to create the workbooks, but I get an error on the Autofilter section of the code. In the video it works, after doing research I haven't been able to see why it is having an issue. Any help is appreciated.

Sub Split()
Dim wswb As String
Dim wssh As String
wswb = ActiveWorkbook.Name
wssh = ActiveSheet.Name
vColumn = inputbox("Please indicate which column (i.e. A, B, C,...), you would like to split by","Column selection")
Columns(vColumn).Copy
Sheets.Add
ActiveSheet.Name = "_Summary"
Range("A1").PasteSpecial
Columns("A").RemoveDuplicates Columns:=1, header:=x1Yes
vCounter = Range("A" & Rows.Count).end(xlUp).Row
For i = 2 To vCounter
    vFilter=Sheets("_Summary").Cells(i, 1)
    Sheets(wssh).Activate
    ActiveSheet.Columns.AutoFilter field:=Columns(vColumn).Column, Criteria1:=vfilter
    Cells.Copy
    Workboks.Add
    Range("A1").PasteSpecial
    If vfilter <> "" Then
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\split results\" & vfilter
    Else
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\split results\_Empty"
    End If
    ActiveWorkbook.Close
    Workbooks(wswb).Activate
Next i
Sheets("_Summary").Delete
End Sub

The line of code I'm getting the error on is:

    ActiveSheet.Columns.AutoFilter field:=Columns(vColumn).Column, Criteria1:=vfilter

Error message is: autofilter method of range class failed


Thank you for your time looking at this,
Fred

 

[Carpaccio]

Hi Fred

I made a change to Workboks.Add (it's missing an "o")- I made it Workbooks.Add

Otherwise, the code runs perfectly for me.

Perhaps the issue is with the data and if it can be used for a Criteria?

HTH

Alan

 

[dmt32]

Hi,
not fully tested but see if following update to your code helps:

Sub Split()
    Dim wbNew As Workbook
    Dim wsFilter As Worksheet, wssh As Worksheet
    Dim rng As Range
    Dim vColumn As Variant
    Dim i As Integer
    Dim msg As String
    
    Set wssh = ActiveSheet
    
    Do
        vColumn = InputBox("Please indicate which column (i.e. A, B, C,...), you would like to split by", "Column selection")
'cancel pressed
        If StrPtr(vColumn) = 0 Then Exit Sub
'check choice in data range
        If wssh.Columns(vColumn).Column > wssh.UsedRange.Columns.Count Then MsgBox "Selection Out Of Data Range", 16, "Out Of Data Range": vColumn = ""
    Loop Until Len(vColumn) > 0
    
    On Error GoTo exitsub
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
    
'add temp filter sheet
    Set wsFilter = Worksheets.Add
    
    wssh.Activate
    
'create filter list
    wssh.Columns(vColumn).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
    
    vCounter = wsFilter.Range("A" & wsFilter.Rows.Count).End(xlUp).Row
    
    For i = 2 To vCounter
        vfilter = wsFilter.Cells(i, 1)
    If Len(vfilter) > 0 Then
        wssh.Columns.AutoFilter field:=wssh.Columns(vColumn).Column, Criteria1:=vfilter
        Set rng = wssh.AutoFilter.Range
        
'remove header
        'Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1)
        
        Set rng = rng.SpecialCells(xlCellTypeVisible)
        
        If Not rng Is Nothing Then
'add new workbook
            Set wbNew = Workbooks.Add(1)
'name sheet
            wbNew.Sheets(1).Name = Left(vfilter, 31)
            If Len(msg) = 0 Then msg = "Workbooks Saved:-" & Chr(10)
            msg = msg & vfilter & ".xlsx" & Chr(10)
            
'copy filtered data to new workbook
            rng.Copy Destination:=wbNew.Sheets(1).Range("A1")
'save new workbook
            wbNew.SaveAs ThisWorkbook.Path & "\split results\" & vfilter & ".xlsx", FileFormat:=51
'close
            wbNew.Close False
            
'clear object variables from memory
        Set wbNew = Nothing
        Set rng = Nothing
'clear filter
        wssh.Range("A1").AutoFilter
        End If
    End If
        Next i
exitsub:
   If Not wsFilter Is Nothing Then wsFilter.Delete
   If Not wbNew Is Nothing Then wbNew.Close False
   
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    
     If Err > 0 Then
        MsgBox (Error(Err)), 48, "Error"
    ElseIf Len(msg) > 0 Then
        MsgBox msg, 48, "Workbooks Saved"
    End If
End Sub

Dave

 

[FredSams]

Thanks for the replies.

Alan - It is possible it could be my data, not sure why it would affect that but I might have to look at it and see if I can reformat it and make up some dummy data see if things work in that fashion.

Dave - thank you very much for the code after trying your code I get an error box that says: "Autofilter method of Range class failed"

I will play with the data see if that fixes it but if any other suggestions are out there I'd be happy to look at it. If the data work changes I will let you know.

Thanks for your time,
Fred

 

[FredSams]

Thanks again guys.

I updated my data set and removed all additional things with it and the code did seem to work. Not really sure what is causing that error with what I currently have in there but at least it does what is needed. Thank you for your time.

Fred