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.

 

[danboi1010]

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

Sorry very new to this.

There is no value in the cell i'm trying to name. It's basically trying to split the sheet on employee, starters and leavers.

 

[Fluff]

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

No apologies needed, everyone's a newcomer at some point.

Open the Vb editor & change the size of the window so that you can still see your workbook (I tend to have it filling the right hand side of the monitor).
Then place the cursor anywhere in the code & press F8, this allows you to "step through" the code line by line.
Every time you press F8 a new line of code will be highlighted in yellow, this is the NEXT line to be run.

When you get to this line

Set wbNew = ActiveWorkbook

A new workbook should have been created containing the "Instructions" sheet.
Is that new workbook the visible workbook?
Then press F8 again & hover the mouse over wbNew & you should get a tool tip appearing showing you the value. What does it say?

 

[danboi1010]

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

Cheers. This is really interesting and some great pointers!!!

Yes the new workbook containing the "instructions"sheet appears and is now visible.

When I then hover over over wbNew it shows wbNew = Nothing

 

[Fluff]

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

If you step through the code again, what is the value of wbNew & cl.value when it fails?
Also does the data sheet get formatted?

 

[danboi1010]

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

The wbNew & clvalue are "c:\user\desktop" and c1.value ="Current Employee"

The it goes back to

If Not .Exists(Cl.Value)

then to

End if

(just above the saveas).

Once it moves onto the saveas thats when the run time error happens.

 

[Fluff]

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

Forgive me, I'm an idiot.
The saveas & close are in the wrong place.
Use this

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
                wbNew.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
                wbNew.SaveAs ThisWorkbook.path & "\" & Cl.Value, 56
                wbNew.Close
            End If
        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



That's brilliant. Problem solved! Thanks very much for your time on this.

Dan.

 

[Fluff]

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

Glad to help & thanks for the feedback.
Sorry it took so long.

 

[danboi1010]

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

Again thanks very much.

Sorry just another quick question. If i wanted it to loop into another sheet and do the same copy and paste on auto filter would i just need to place the following code at the end of the end if and before the wbnew and just replace the sheet name? Please don't worry if it's not a quick answer as i can just run you code on two different spreadsheets and just manually attach them.

Thanks,
Dan.

[COLOR=#333333][FONT=Courier]Set ws1 = ThisWorkbook.Sheets("Actual")[/FONT][/COLOR][COLOR=#333333][FONT=Courier]    Usdrws = ws1.Range("E" & Rows.Count).End(xlUp).Row[/FONT][/COLOR]
[COLOR=#333333][FONT=Courier]    Set rData = ws1.Range("A1:E" & Usdrws)[/FONT][/COLOR]
[COLOR=#333333][FONT=Courier]    With CreateObject("scripting.dictionary")[/FONT][/COLOR]
[COLOR=#333333][FONT=Courier]        For Each Cl In ws1.Range("B2:B" & Usdrws)[/FONT][/COLOR]
[COLOR=#333333][FONT=Courier]            If Not .Exists(Cl.Value) Then[/FONT][/COLOR]
[COLOR=#333333][FONT=Courier]                .Add Cl.Value, Nothing[/FONT][/COLOR]
[COLOR=#333333][FONT=Courier]
[/FONT][/COLOR]
[COLOR=#333333][FONT=Courier]                [/FONT][/COLOR]
[COLOR=#333333][FONT=Courier]                rData.AutoFilter field:=2, Criteria1:=Cl.Value[/FONT][/COLOR]
[COLOR=#333333][FONT=Courier]                rData.SpecialCells(xlVisible).copy wbNew.Sheets(Cl.Value).Range("A1")

[/FONT][/COLOR]

 

[Fluff]

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

I very much doubt it.
Are the values in both sheets exactly the same?