Copy row to new sheet if cell value is a number

Stan101

New Member
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:

VBA Code:
``````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.

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December

Zot

Well-known Member
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

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

Michael M

Well-known Member
VBA Code:
``````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

New Member

VBA Code:
``````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

Well-known Member
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

Well-known Member

Try this

VBA Code:
``````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

Well-known Member
Hello Stan,

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

VBA Code:
``````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

New Member
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.

VBA Code:
``````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
Worksheets("loor CSV").Delete
End If
Next Sheet

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

ActiveSheet.Copy

ActiveWorkbook.SaveAs "D:\Excel Files\CSV TEST\loor.CSV", FileFormat:=6
ActiveWorkbook.Close

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``````

Replies
6
Views
402
Replies
5
Views
297
Replies
2
Views
493
Replies
11
Views
368
Replies
11
Views
154

1,132,703
Messages
5,654,823
Members
418,155
Latest member
demasisi

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back