Code that auto filters but also need to add copy workbook

[danboi1010]

Hi, have been on this forum before, only a few times but unfortunately was made redundant and lost my login details........never use your work details for logging in!!!

I have a query that i hope someone can help with.

I've adapted a vba code from the net to copy and paste from my data template (the template has an instructions sheet and a data sheet)to a new workbook based on an auto filter. It splits the data on column 2 and then pastes and saves to a new workbook, it loops through the criteria and works well. The issue that I have is that I would also like to copy and paste the template instructions page into each of the new workbooks. Please see the below code:

Sub ExtractToNewWorkbook()


Dim ws1     As Worksheet


Dim wsNew  As Workbook


Dim rData  As Range


Dim rfl    As Range


Dim status  As String


Dim sfilename As String






Set ws1 = ThisWorkbook.Sheets("Data Validation")




'Apply advance filter in your sheet


With ws1


Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 5).End(xlUp))


.Columns(.Columns.Count).Clear


.Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True






For Each rfl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))


status = rfl.Text




Set wsNew = Workbooks.Add
Sheets("Sheet2").Activate




sfilename = status & ".xlsx"


'Set the Location


ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sfilename


Application.DisplayAlerts = False


ws1.Activate


rData.AutoFilter Field:=2, Criteria1:=status


rData.Copy


Windows(status).Activate


ActiveSheet.Paste
Cells.Select
With Selection.Font
.Name = "Arial"
.Size = 8
End With


Cells.Select
With Selection
.VerticalAlignment = xlBottom
.HorizontalAlignment = xlLeft
Selection.ColumnWidth = 80
Cells.EntireColumn.AutoFit
End With




Rows.Select
Selection.RowHeight = 41.25




ActiveWorkbook.Close SaveChanges:=True


Next rfl


Application.DisplayAlerts = True


End With


ws1.Columns(Columns.Count).ClearContents


rData.AutoFilter


End Sub

Any help would be appreciated.

Thanks,
Dan.

 

[Fluff]

Re: Help with VBA coding - have a code that auto filters but also need to add copy workbook

Hi & welcome to the board.
Does this do what you need?

Sub ExtractToNewWorkbook()

    Dim ws1    As Worksheet
    Dim wsNew  As Workbook
    Dim rData  As Range
    Dim UsdRws As Long
    Dim Cl     As Range
    
Application.ScreenUpdating = False

    Set ws1 = ThisWorkbook.Sheets("Data Validation")
    UsdRws = ws1.Range("E" & Rows.Count).End(xlUp).Row
    Set rData = ws1.Range("A1:E" & UsdRws)
    With CreateObject("scripting.dictionary")
        For Each Cl In ws1.Range("B2:B" & UsdRws)
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                
                Sheets("[COLOR=#ff0000]Instructions[/COLOR]").copy
                Set wsNew = ActiveWorkbook
                Sheets.Add(after:=Sheets(1)).Name = Cl.Value
                
                rData.AutoFilter Field:=1, Criteria1:=Cl.Value
                rData.SpecialCells(xlVisible).copy wsNew.Sheets(Cl.Value).Range("A1")
                
                With wsNew.Sheets(Cl.Value).Cells
                    .Font.Name = "Arial"
                    .Font.Size = 8
                    .VerticalAlignment = xlBottom
                    .HorizontalAlignment = xlLeft
                    .EntireColumn.AutoFit
                    .RowHeight = 41.25
                End With
            End If
            wsNew.SaveAs ThisWorkbook.path & "\" & Cl.Value, 52
            wsNew.Close
        Next Cl
    End With
    rData.AutoFilter
    
End Sub

Change the sheet name in red to suit

 

[danboi1010]

Re: Help with VBA coding - have a code that auto filters but also need to add copy workbook

Hi Fluff,

Thanks for looking into this and the code. I've tried to run it and i get a runtime error message on:

[COLOR=#333333]wsNew.SaveAs ThisWorkbook.path & "\" & Cl.Value, 52

[/COLOR]I've tried to add .xls to the end and searched for the range cl.value, 52 but i think it's above my abilities!!!

Any help would be great.

Thanks,
Dan.

 

[Fluff]

Re: Help with VBA coding - have a code that auto filters but also need to add copy workbook

If you want it as an xls format use this

Sub ExtractToNewWorkbook()

    Dim ws1    As Worksheet
    Dim wsNew  As Workbook
    Dim rData  As Range
    Dim Usdrws As Long
    Dim Cl     As Range
    
Application.ScreenUpdating = False

    Set ws1 = ThisWorkbook.Sheets("Data Validation")
    Usdrws = ws1.Range("E" & Rows.Count).End(xlUp).Row
    Set rData = ws1.Range("A1:E" & Usdrws)
    With CreateObject("scripting.dictionary")
        For Each Cl In ws1.Range("B2:B" & Usdrws)
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                
                Sheets("Instructions").copy
                Set wsNew = ActiveWorkbook
                Sheets.Add(after:=Sheets(1)).Name = Cl.Value
                
                rData.AutoFilter field:=1, Criteria1:=Cl.Value
                rData.SpecialCells(xlVisible).copy wsNew.Sheets(Cl.Value).Range("A1")
                
                With wsNew.Sheets(Cl.Value).Cells
                    .Font.Name = "Arial"
                    .Font.Size = 8
                    .VerticalAlignment = xlBottom
                    .HorizontalAlignment = xlLeft
                    .EntireColumn.AutoFit
                    .RowHeight = 41.25
                End With
            End If
            wsNew.SaveAs ThisWorkbook.path & "\" & Cl.Value, [COLOR=#ff0000]56[/COLOR]
            wsNew.Close
        Next Cl
    End With
    rData.AutoFilter
    
End Sub

 

[danboi1010]

Re: Help with VBA coding - have a code that auto filters but also need to add copy workbook

HI Fluff,

Again many thanks for looking into this for me. I'm still having problems get the file to save. I keep getting a run time automation and when i try to debug the below is highlighted in yellow:

wsNew.SaveAs ThisWorkbook.path & "\" & Cl.Value, 56

I've tried searching the net for an answer but with no luck. I assume the C1 code relates to name the file as the specified range but it's the ,56. Again i think this relates to what type of file to save it as? I've tried to change the file names but again i keep getting the error message.

Thanks,
Dab

 

[Fluff]

Re: Help with VBA coding - have a code that auto filters but also need to add copy workbook

If you are using xl 2003 try

Sub ExtractToNewWorkbook()

    Dim ws1    As Worksheet
    Dim wbNew  As Workbook
    Dim rData  As Range
    Dim Usdrws As Long
    Dim Cl     As Range
    
Application.ScreenUpdating = False

    Set ws1 = ThisWorkbook.Sheets("Data Validation")
    Usdrws = ws1.Range("E" & Rows.Count).End(xlUp).Row
    Set rData = ws1.Range("A1:E" & Usdrws)
    With CreateObject("scripting.dictionary")
        For Each Cl In ws1.Range("B2:B" & Usdrws)
            If Not .Exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                
                Sheets("Instructions").copy
                Set wbNew = ActiveWorkbook
                Sheets.Add(after:=Sheets(1)).Name = Cl.Value
                
                rData.AutoFilter field:=2, Criteria1:=Cl.Value
                rData.SpecialCells(xlVisible).copy wbNew.Sheets(Cl.Value).Range("A1")
                
                With wbNew.Sheets(Cl.Value).Cells
                    .Font.Name = "Arial"
                    .Font.Size = 8
                    .VerticalAlignment = xlBottom
                    .HorizontalAlignment = xlLeft
                    .EntireColumn.AutoFit
                    .RowHeight = 41.25
                End With
            End If
            wbNew.SaveAs ThisWorkbook.path & "\" & Cl.Value
            wbNew.Close
        Next Cl
    End With
    rData.AutoFilter
    
End Sub

Note:
I've realised that there was a slight flaw in the earlier code, so delete any previous code & use this.

 

[danboi1010]

Re: Help with VBA coding - have a code that auto filters but also need to add copy workbook

HI Fluff,

Thanks.
It was almost there! I still get the automation error on the wb.new save as however, the code now creates the first file and populates both sheet one and sheet two, it then saves the first file but it doesn't loop though to the next file.
Dan.

 

[Fluff]

Re: Help with VBA coding - have a code that auto filters but also need to add copy workbook

What is the error message that you get?
Also what version of Xl are you using?

 

[danboi1010]

Re: Help with VBA coding - have a code that auto filters but also need to add copy workbook

xl 2010.

The runtime error'-21477221080(800401a8): Automation Error.

Debug the highlights the wbNew Saveas line.

 

[Fluff]

Re: Help with VBA coding - have a code that auto filters but also need to add copy workbook

What is the value of wbNew, when you get that error?