Copy row to new sheet if cell value is a number

[Stan101]

I am try to have a whole row copied to the next available row in different worksheet within the same workbook if a cell value is numeric.

Sheet "Master" contains thousands of rows of data. there are some blank rows in between these data.
Working sequentially by row through sheet "Master", If cell "AI" on a row has a numeric value (ie: whole number or decimal) then copy it to "Sheet3" in the next available line.

This is what I have so far:

Sub CopyToOtherSheet()
    Dim r As Range
    Dim i As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = ActiveWorkbook.Worksheets("Master")
    Set Target = ActiveWorkbook.Worksheets("Sheet3")

    j = 1
  
    For Each r In Source.Range("AI:AI1000")
        If IsNumeric(r) = True Then
           Source.Rows(r.Row).Copy Target.Rows(i)
           i = i + 1
        End If
    Next r
End Sub

I have a fixed source range because I can't recall how to count total rows and have just be trying to get the rest working before I attempt to tackle that.

My ultimate goal would be to not only get the above working but to add the following so I may use it potentially for future use:
- Instead of having a fixed "sheet 3" destination, create it based on a cell name or sheet name after a test to see if it already created.
- Have a variant that works with non numeric values.
- Have this run on close of the workbook that holds sheet"Master" if possible.

Can anyone see what I am doing wrong? Any assistance would be greatly appreciated.

 

[Zot]

What is the problem?

I see that you put j=1 but in loop you have i=i+1. So, initial i=0 will give error

 

[Zot]

One way to find last occupied row (from bottom up):
LastRow = Source.Cells(Rows.Count, "A").End(xlUp).Row

 

[Michael M]

How about

Sub CopyToOtherSheet()
Dim r As Long, i As Long, Source As Worksheet, Target As Worksheet
Dim lr As Long, lr2 As Long
Set Source = Worksheets("Master")
Set Target = Worksheets("Sheet3")
lr = Source.Cells(Rows.Count, "AI").End(xlUp).Row
lr2 = Target.Cells(Rows.Count, "A").End(xlUp).Row + 1
    For r = 1 To lr
        If IsNumeric(Range("AI" & r).Value) = True Then
           Rows(r).Copy Target.Range("A" & lr2)
           lr2 = Target.Cells(Rows.Count, "A").End(xlUp).Row + 1
        End If
    Next r
End Sub

 

[Stan101]

How about

Sub CopyToOtherSheet()
Dim r As Long, i As Long, Source As Worksheet, Target As Worksheet
Dim lr As Long, lr2 As Long
Set Source = Worksheets("Master")
Set Target = Worksheets("Sheet3")
lr = Source.Cells(Rows.Count, "AI").End(xlUp).Row
lr2 = Target.Cells(Rows.Count, "A").End(xlUp).Row + 1
    For r = 1 To lr
        If IsNumeric(Range("AI" & r).Value) = True Then
           Rows(r).Copy Target.Range("A" & lr2)
           lr2 = Target.Cells(Rows.Count, "A").End(xlUp).Row + 1
        End If
    Next r
End Sub

Hi Michael,

I tried this code and it is running but it is running very slowly. It has been running for about 7 minutes so far. CPU load is light and ram use is light though. I see the word "Calculating" in the bottom left of the Excel screen so it is still running. In that time it copied 350 lines to sheet 3.

I stopped the code eventually with F5 and see that in Sheet3, every line from Sheet Master has started to be copied regardless of what is in cell AI.

What is the problem?

I see that you put j=1 but in loop you have i=i+1. So, initial i=0 will give error

I don't know what happened there.

But when all J I still get no result.

 

[Michael M]

1. Is Master the active sheet when the process is run
2. Are the cells solely numeric or a mixture of text and numbers
3. how many rows are involved here ?
The code ran fine for me !!
AND
what is the relevence of J as it doesn't appear to have any impact on the code as first presented ?

 

[Zot]

Try this

Sub CopyToOtherSheet()
    Dim r As Range
    Dim i As Long, eRow As Long
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = ActiveWorkbook.Worksheets("Master")
    Set Target = ActiveWorkbook.Worksheets("Sheet3")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    eRow = Source.Range("AI" & Source.Rows.Count).End(xlUp).Row
    i = 1
  
    For Each r In Source.Range("AI1", "AI" & eRow)
        If IsNumeric(r) = True Then
           Source.Rows(r.Row).Copy Target.Rows(i)
           i = i + 1
        End If
    Next r
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[vcoolio]

Hello Stan,

If the values are actually numeric (refer to Michael's post #6) then this could work for you:-

Sub CopyToOtherSheet()
    
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = Sheets("Master")
    Set Target = Sheets("Sheet3")
    
Application.ScreenUpdating = False

    Source.Range("AI2", Source.Range("AI" & Source.Rows.Count).End(xlUp)).SpecialCells(2, 1).EntireRow.Copy Target.Range("A" & Rows.Count).End(3)(2)
   
Application.ScreenUpdating = True

End Sub

I'm assuming that there are headings in row1 with data starting in row2.

I hope that this helps.

Cheerio,
vcoolio.

 

[Stan101]

Thank you for all your assistance everyone. I will look at all your code and use it to renew my learning.

I have actually got the result I need. I stopped and looked at what I really wanted to achieve and came up with what I think is an easier solution. And best of all, it works for me.

I actually think the hardest part of VBA for me is formatting and roughing out what I really need to achieve and the flow I should use to get there. I see lots of code training on line. I see very little code planning tutorials online. I also forget what commands are actually available to me.

Any way thanks again. This is how I achieved what I needed. It might assist someone else at some stage.

Public Sub CopySheetToEndAnotherWorkbook()

Dim currentwb As Workbook
Set currentwb = ThisWorkbook

    Worksheets("Master").Copy After:=Worksheets("Cal")
      
For Each Sheet In ActiveWorkbook.Worksheets
    If Sheet.Name = "loor CSV" Then
        Application.DisplayAlerts = False
        Worksheets("loor CSV").Delete
        Application.DisplayAlerts = True
    End If
Next Sheet


    ActiveSheet.Name = "loor CSV"
    DeleteBlankRows
    currentwb.Save

Application.DisplayAlerts = False

 ActiveSheet.Copy

 ActiveWorkbook.SaveAs "D:\Excel Files\CSV TEST\loor.CSV", FileFormat:=6
    ActiveWorkbook.Close
    
Application.DisplayAlerts = True
    
currentwb.Worksheets("loor").Activate
End Sub

Sub DeleteBlankRows()
On Error Resume Next
    Columns("AI").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub