Filter - Copy Paste - Save As

[jaime1182]

Good morning / evening everyone!

I hope everyone is well. I was wondering if I could pick the brains trust here.

I have a workbook with two worksheets.

I have to filter the list on Worksheet A and copy paste the values into Worksheet B and then save copy as the name in Cell A2.

At the moment, I have managed to do get it to autofilter and create a new individual worksheets with the data.

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String

sht = "Input"

last = Sheets(sht).Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:J" & last)

Sheets(sht).Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("N1"), Unique:=True

For Each x In Range([N2], Cells(Rows.Count, "N").End(xlUp))

With rng
.AutoFilter
.AutoFilter Field:=1, 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

At the moment, I am now copying the unique lists in those "new" worksheets into Worksheet B and then deleting all the other worksheets and doing a save as.

I am sure there has to be a shortcut way of auto-filtering Worksheet A and copying and pasting directly into Worksheet B, doing a save file as using the text in cell A2 and then clearing Worksheet B and looping again.

Can anyone help? Much thanks!

 

[John_w]

I have to filter the list on Worksheet A and copy paste the values into Worksheet B and then save copy as the name in Cell A2.

In this macro, the data to be filtered is on the worksheet named "Input" (the same as your code) and the filtered data is copied to the worksheet named "Output" (defined by the outputSheetName = "Output" line).

Public Sub Filter_and_Save_As_Workbook()

    Dim outputSheetName As String
    Dim outputSheet As Worksheet
    Dim last As Long
    Dim dataRange As Range
    Dim colAunique As Range
    
    Application.ScreenUpdating = False
    
    outputSheetName = "Output"
    Set outputSheet = Worksheets(outputSheetName)
    
    With Worksheets("Input")
    
        last = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set dataRange = .Range("A1:J" & last)
        .Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("N1"), Unique:=True
    
        For Each colAunique In .Range("N2", .Cells(Rows.Count, "N").End(xlUp))
        
            outputSheet.Cells.Clear
            
            With dataRange
                .AutoFilter
                .AutoFilter Field:=1, Criteria1:=colAunique.Value
                .SpecialCells(xlCellTypeVisible).Copy outputSheet.Range("A1")
                
                'Save output sheet as new workbook
                
                With outputSheet
                    .Name = colAunique.Value
                    .Copy
                    Application.DisplayAlerts = False 'suppress warning if file already exists
                    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & colAunique.Value & ".xlsx"
                    ActiveWorkbook.Close SaveChanges:=False
                    Application.DisplayAlerts = True
               End With
            
            End With
            
        Next
    
        'Turn off filter
        .AutoFilterMode = False
    
        .Range("N1", .Cells(Rows.Count, "N").End(xlUp)).Cells.Clear

    End With
                
    With outputSheet
        .Cells.Clear
        .Name = outputSheetName
    End With
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Sub

 

[jaime1182]

Exactly what I was after!! Brilliant! Saved me a whole lot of work (if I'm not careful, I might macro myself out of a job ...)

Thanks again!