Macro to copy paste rows if cell value greater than 0

[MPFraser7]

For range (A2:I413), I want to copy all rows where column I is greater than 0 and paste it in a new sheet and format this new sheet as a table. The values in column I range from 0, "", #value !, negative and positive numbers. I want to copy rows where the numbers are positive. Any help on this?

 

[hoyinsk8]

the easiest way is to use filter to select the number you want in column I and manually copy and paste to a new worksheet

 

[MPFraser7]

This step has to be automated for my tool to work for intended users. Manual copy/pasting is not an option.

 

[hoyinsk8]

i see.. are you familiar with Array? you can run your loop to see if the value of the cell is greater than 0 and save this in an array, then copy the array to a new worksheet

set your range to be the range you wanted. Assign a 2 -D array NEW(500,2) , and a variable k, do a 'for loop say i = 2 to 413, have an if statement to check if cells(i,"I")>0 then
a for loop for columns, say j=1 to 9, new(k,j)=cells(i,j).value

hope this make sense, if not i can do the full code

 

[MPFraser7]

Not very familiar with Array. I was using the following code but it's copy/pasting all rows in random sheets rather than copying rows from Sheet 1where H >0 into Sheet 2.

Dim rng As Range
Dim cell As Range
Dim lr As Long
Dim ws1 As Worksheet
Dim ws2 As WorksheetSet ws1 = Sheet1
Set ws2 = Sheet2

lr = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws1.Range("H1:H" & lr)

For Each cell In rng
If cell.Value > 0 Then
cell.EntireRow.Copy
ws2.Select
If ws2.Range("A1").Value = "" Then
ws2.Range("a1").PasteSpecial xlPasteValues
Else
Cells((Cells(Rows.Count, "a").End(xlUp).Row) + 1, "a").PasteSpecial xlPasteValues
End If
End If
Next cell

Application.CutCopyMode = False
Range("A1").Select

End Sub

 

[hoyinsk8]

Not very familiar with Array. I was using the following code but it's copy/pasting all rows in random sheets rather than copying rows from Sheet 1where H >0 into Sheet 2.

Dim rng As Range
Dim cell As Range
Dim lr As Long
Dim ws1 As Worksheet
Dim ws2 As WorksheetSet ws1 = Sheet1
Set ws2 = Sheet2

lr = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws1.Range("H1:H" & lr)

For Each cell In rng
If cell.Value > 0 Then
cell.EntireRow.Copy
ws2.Select
If ws2.Range("A1").Value = "" Then
ws2.Range("a1").PasteSpecial xlPasteValues
Else
Cells((Cells(Rows.Count, "a").End(xlUp).Row) + 1, "a").PasteSpecial xlPasteValues
End If
End If
Next cell

Application.CutCopyMode = False
Range("A1").Select

End Sub

Dim lr As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheet("Sheet 1")
Set ws2 = Sheet("Sheet 2")
dim i as long
dim j as long
dim k as long


lr = ws1.usedrange.rows.count


k=2
For i = 2 to lr


If ws1.cells(i,"I")> 0 Then
for j= 1 to 9
ws2.cells(k,j)=ws1.cells(i,j).value
k=k+1
next j
end if
next i

 

[Fluff]

@MPFraser7
Try this modified version your code

Dim rng As Range
Dim cell As Range
Dim lr As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = [COLOR=#0000ff]Sheets("Sheet1")[/COLOR]
Set ws2 = [COLOR=#0000ff]Sheets("Sheet2")[/COLOR]

lr = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws1.Range("H1:H" & lr)

For Each cell In rng
    If cell.Value > 0 Then
        cell.EntireRow.copy
        If ws2.Range("A1").Value = "" Then
            ws2.Range("A1").PasteSpecial xlPasteValues
        Else
            [COLOR=#0000ff]ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues[/COLOR]
        End If
    End If
Next cell

Application.CutCopyMode = False
Range("A1").Select

modifications in blue

 

[MPFraser7]

Thank you Fluff! This is working just fine.

 

[Fluff]

Glad to help & thanks for the feedback

 

[Yancy]

I have a similar issue to MPFraser7 but I have a spreadsheet with several sheet tabs. When column D (Ext Unit) is greater than 0 on any tab, I want to copy that entire line to a new sheet in the form of a table. I have been trying to tweak the code from this thread to make it work but I cannot get it to work.

Does anyone have any suggestions? I will admit that I am a noob so this is probably completely wrong.

Any help you can give would be appreciated!

~ Yancy

Spreadsheet

Dim rng As Range
Dim cell As Range
Dim lr As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet3")
Set ws2 = Sheets("Sheet19")

lr = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws1.Range("D1:D" & lr)

For Each cell In rng
If cell.Value > 0 Then
cell.EntireRow.copy
If ws2.Range("A1").Value = "" Then
ws2.Range("A1").PasteSpecial xlPasteValues
Else
ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
End If
Next cell

Application.CutCopyMode = False
Range("A1").Select