Hi,

I've been playing with this for a bit and had a search around and haven't been able to find the answer to my issue. I have a spreadsheet that contains geological drilling results for different ore bodies. All results go into the one spreadsheet and I'm after a macro that will filter based on each ore body and export the entire rows from each ore body separately to new workbooks. I've had this work, BUT once the new workbooks have been created I would then like to filter based on a certain column and then copy the results into new sheets based on a value ranges of the filtered cell and then rename these sheets to reflect the value range of that sheet (i.e. I want to filter based on a "GMM" value between ranges "<25", "25-50", "50-75", "75-100", "100-200", "200-300", ">300" and have those ranges be the sheet name at the end). I've got a macro, but it fails once the data gets to the new workbook. 

Sub Extract_All_Data_To_New_Workbook()
    
    'this macro assumes that your first row of data is a header row.
    'will copy all filtered rows from one worksheet, to another blank workbook
    'each unique filtered value will be copied to it's own workbook
    
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range
    Dim filePath As String
    Dim NewName As String
    
    
    
    ' Set the filter range (from A1 to the last used cell in column A)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = Range("K1", Range("K" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = False
    
    With rngFilter
        
        ' Filter column A to show only one of each item (uniques) in column A
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        ' Set a variable to the Unique values
        Set rngUniques = Range("K2", Range("K" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        ' Clear the filter
        ActiveSheet.ShowAllData
        
    End With
    
    ' Filter, Copy, and Paste each unique to its own new workbook
    For Each cell In rngUniques
    
        ' Create a new workbook for each unique value
        Set wbDest = Workbooks.Add(xlWBATWorksheet)
                
        'NOTE - this filter is on column A (field:=1), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
        
        ' Copy and paste the filtered data to its new workbook
        rngFilter.EntireRow.Copy
        With wbDest.Sheets(1).Range("A1")
            .PasteSpecial xlPasteColumnWidths           'Paste column widths
            .PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
        End With
        Application.CutCopyMode = True
        
     filePath = "G:\Mining_Geology\05. Diamond Drilling\14. Long Projection Files\Sample XLS\": NewName = filePath & cell.Value & ".xlsx"
       
        
        For Each c In Worksheets("Sheet1").Range("J1:J" & bottomL)
            If c.Value < 25 Then
            c.EntireRow.Copy Worksheets("Sheet2").Range("A" & x)
            End If
        Next c
        
        For Each c In Worksheets("Sheet1").Range("J1:J" & bottomL)
            If c.Value < 50 And c.Value > 25 Then
            c.EntireRow.Copy Worksheets("Sheet3").Range("A" & x)
            End If
        Next c

        For Each c In Worksheets("Sheet1").Range("J1:J" & bottomL)
            If c.Value < 75 And c.Value > 50 Then
            c.EntireRow.Copy Worksheets("Sheet4").Range("A" & x)
            End If
        Next c
        
        For Each c In Worksheets("Sheet1").Range("J1:J" & bottomL)
            If c.Value < 100 And c.Value > 75 Then
            c.EntireRow.Copy Worksheets("Sheet5").Range("A" & x)
            End If
        Next c
        
        For Each c In Worksheets("Sheet1").Range("J1:J" & bottomL)
            If c.Value < 200 And c.Value > 100 Then
            c.EntireRow.Copy Worksheets("Sheet6").Range("A" & x)
            End If
        Next c
        
        For Each c In Worksheets("Sheet1").Range("J1:J" & bottomL)
            If c.Value < 300 And c.Value > 200 Then
            c.EntireRow.Copy Worksheets("Sheet7").Range("A" & x)
            End If
        Next c
        
        For Each c In Worksheets("Sheet1").Range("J1:J" & bottomL)
            If c.Value > 300 Then
            c.EntireRow.Copy Worksheets("Sheet8").Range("A" & x)
            End If
        Next c
        
            ' Name the destination sheet
        wbDest.Sheets(1).Name = "SMP_" & cell.Value
        
        'Save the destination workbook and close
        wbDest.SaveAs Filename:=NewName
        wbDest.Close False 'Close the new workbook
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub