Copy filtered data from workbook to new workbook

[Kate1]

I am trying to copy filtered data from a .xlsm workbook (an image, headings, filtered data) to a new .xlsx workbook. I found some code that I have modified which copies the data in the active worksheet to a new workbook allowing the user to enter their own title and save as. The issue is that the code copies all data, not just the filtered data. Could anyone assist with code that copies only the filtered data? If there is a better way to write the code, that would be appreciated.

[COLOR=#222222][FONT=Verdana][FONT=Verdana]Sub GenerateSeparateFile()[/FONT][/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana][FONT=Verdana]    Dim ThisFile As String
    Dim NewFile As String
    Dim NewFileType As String
       
    ThisFile = ThisWorkbook.FullName
    NewFileType = "Excel 2016 (*.xlsx), .*xlsx"
    NewFile = Application.GetSaveAsFilename(InitialFileName:=NewFileName, FileFilter:=NewFileType)
    
    ActiveWorkbook.Sheets(2).Copy
    ActiveWorkbook.SaveAs Filename:=NewFile, FileFormat:=51
       
    ThisWorkbook.Sheets(2).Range("A1:H5000").Copy
    ActiveWorkbook.Sheets(1).Range("A1:H5000").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
        
    Application.ScreenUpdating = True[/FONT][/FONT][/COLOR]
[COLOR=#222222][FONT=Verdana][FONT=Verdana]End Sub[/FONT][/FONT][/COLOR]

 

[James006]

Hi,

In order to copy only the Filtered range ...

Dim rFiltered As Range
On Error Resume Next
    Set rFiltered = Range("Your_Range").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

Hope this will help

 

[Kate1]

Hello, thank you but I still can’t get it to work. I’ve also tried to modify the code but still get the same unfiltered. This is what I’ve modified it to now. Appreciate any assistance. Thanks

Sub SeparatePaymentFile()
 
    Dim ThisFile As String
    Dim NewFile As String
    Dim NewFileType As String
    Dim rFiltered As Range
    Dim NewFileName As String
     
    Set rFiltered = Worksheets(2).Range("A1:H5000")
    NewFileName = ("Contractor Payment File")
           
    Application.ScreenUpdating = False
   
    ThisFile = ThisWorkbook.FullName
    NewFileType = "Excel 2016 (*.xlsx), .*xlsx"
    NewFile = Application.GetSaveAsFilename(InitialFileName:=NewFileName, FileFilter:=NewFileType)
   
    ActiveWorkbook.Sheets(2).Copy
    ActiveWorkbook.SaveAs Filename:=NewFile, FileFormat:=51
   
    On Error Resume Next
    With rFiltered
        .SpecialCellsxlCellTypeVisible.Copy Desgination:=Worksheets(2).Range("A1")
    End With
    On Error GoTo 0
   
    Range("A1").Select
   
    Application.ScreenUpdating = True
 
End Sub

 

[JoeMo]

Hello, thank you but I still can’t get it to work. I’ve also tried to modify the code but still get the same unfiltered. This is what I’ve modified it to now. Appreciate any assistance. Thanks

Sub SeparatePaymentFile()
 
    Dim ThisFile As String
    Dim NewFile As String
    Dim NewFileType As String
    Dim rFiltered As Range
    Dim NewFileName As String
     
    Set rFiltered = Worksheets(2).Range("A1:H5000")
    NewFileName = ("Contractor Payment File")
           
    Application.ScreenUpdating = False
   
    ThisFile = ThisWorkbook.FullName
    NewFileType = "Excel 2016 (*.xlsx), .*xlsx"
    NewFile = Application.GetSaveAsFilename(InitialFileName:=NewFileName, FileFilter:=NewFileType)
   
    ActiveWorkbook.Sheets(2).Copy
    ActiveWorkbook.SaveAs Filename:=NewFile, FileFormat:=51
   
    On Error Resume Next
    With rFiltered
        .SpecialCells[COLOR=#ff0000][B]([/B][/COLOR]xlCellTypeVisible[B][COLOR=#ff0000])[/COLOR][/B].Copy [B][COLOR=#ff0000]Destination[/COLOR][/B]:=Worksheets(2).Range("A1")
    End With
    On Error GoTo 0
   
    Range("A1").Select
   
    Application.ScreenUpdating = True
 
End Sub

You have some missing punctuation and misspellings in what you posted - see corrections in bold red above.

 

[Kate1]

Thanks but now I feel really silly and have fixed. I actually have a pivot table to copy and paste values. I had been trying to work out how that fits with my current code with no success. Would appreciate some clues.