copy row to new workbook if a cell is 0.1 or less

[rooster05]

hello

i have a workbook titled 3 months and in this wb i have Sheet1 which contains data i need copying to a new wb if cell in column D is 0.1 or less, this could be 1 or 200 rows. this new wb would need to be saved in a different filepath. i'm assuming this is possible but i am not sure how to do it any help would be greatly appreciated

 

[Caleeco]

Hello Rooster,

Without knowing all the details of your sheet, this is my first guess at what might work. Just remember to change the filepath/filename at the end of the code!

Sub FindandSave()
    Dim wb As Workbook, wbNew As Workbook
    Dim i As Integer, j As Integer
    Dim arr() As Variant
    
    Application.ScreenUpdating = False
    Set wb = ActiveWorkbook
    Set wbNew = Workbooks.Add
    j = 1
    With wb.Sheets("Sheet1")
        For i = 1 To 200
            If .Range("D" & i).Value <= 0.1 Then
                .Rows(i).Copy wbNew.Sheets("Sheet1").Rows(j)
                j = j + 1
            End If
        Next i
    End With
    Application.ScreenUpdating = True
    wbNew.SaveAs "C:\Users\Name\Desktop\Filename.xls"
End Sub

Hope that helps
Caleeco

 

[rooster05]

Caleeco,

that is perfect and works a treat.
as an addition to this would i be able to copy the headers too

 

[Caleeco]

Hi Rooster,

Ok that's great, thanks for letting me know it worked! Yes, i can modify it slightly as shown below (assumes headers are in row 1)

Sub FindandSave()
    Dim wb As Workbook, wbNew As Workbook
    Dim i As Integer, j As Integer
    Dim arr() As Variant
    
    Application.ScreenUpdating = False
    Set wb = ActiveWorkbook
    Set wbNew = Workbooks.Add
    j = 2
    With wb.Sheets("Sheet1")
        .Rows(1).Copy wbNew.Sheets("Sheet1").Rows(1)
        For i = 1 To 200
            If .Range("D" & i).Value <= 0.1 Then
                .Rows(i).Copy wbNew.Sheets("Sheet1").Rows(j)
                j = j + 1
            End If
        Next i
    End With
    Application.ScreenUpdating = True
    wbNew.SaveAs "C:\Users\Name\Desktop\Filename.xls"
End Sub

Hope that helps
Caleeco

 

[MARK858]

Just a different method to try just as I was bored...

Sub FindandSave()
    Dim wb As Workbook, wbNew As Workbook

    Application.ScreenUpdating = False
    Set wb = ActiveWorkbook
    Set wbNew = Workbooks.Add

    With wb.Sheets("Sheet1").Range("D1:D200")
        .AutoFilter 1, "<0.1"
        On Error Resume Next
        .SpecialCells(12).EntireRow.Copy wbNew.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp)(2)
        On Error GoTo 0
        .AutoFilter
    End With
    
    wbNew.Sheets("Sheet1").Rows(1).Delete
    Application.ScreenUpdating = True
    wbNew.SaveAs "C:\Users\Name\Desktop\Filename.xls"
End Sub

 

[rooster05]

Caleeco / Mark858,

thanks for replying so quick, i'm unable to apply these at the moment. i have one question (sorry), apologies for not asking at the outset if i were to change the copy part to cut how could this be done without removing the headers. apologies again

 

[MARK858]

With mine it's easier just to delete the range rather than use cut.

Sub FindandSave()
    Dim wb As Workbook, wbNew As Workbook

    Application.ScreenUpdating = False
    Set wb = ActiveWorkbook
    Set wbNew = Workbooks.Add

    With wb.Sheets("Sheet1").Range("D1:D200")
        .AutoFilter 1, "<0.1"
        On Error Resume Next
        .SpecialCells(12).EntireRow.Copy wbNew.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp)(2)
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
        On Error GoTo 0
        .AutoFilter
    End With

    wbNew.Sheets("Sheet1").Rows(1).Delete
    Application.ScreenUpdating = True
    wbNew.SaveAs "C:\Users\Name\Desktop\Filename.xls"
End Sub