VBA: Delete Row if Value is Zero & Copy Data Based on Values

[unknownymous]

Hello Guys,

Hope all is well.

I have a sheet with more than more or less 100k lines. I need to trim the data first by omitting rows with "0" or blank as Value in Row R (Sheet 1). I found below code but it's taking much time probably because the file is too large.

Sub DeleteRow() 'DeleteRow ot Value is Zero

Dim MyRange As Range
Set MyRange = Range("R1:R500000")

Do
Set myCell = MyRange.Find("0", LookIn:=xlValues)
If Not myCell Is Nothing Then
myCell.EntireRow.Delete
End If
Loop While Not myCell Is Nothing
End Sub


Once done, I need to create 2 tab sheets on the same file namely - "Team P" and "Team N". Data is given in is Sheet 1 column B

Team P sheet - Copy those positive change from Sheet 1 (column B)
Team N sheet - Copy those negative change from Sheet 1 (column B)

I found and tweak this code but its taking too much time.

Sub CopyPositive ()

Dim i As Range
For Each i In Range("B1:B250000")
If i.Value > 0 Then
i.Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Team P").Range("A250000").End(xlUp).Offset(1, 0).PasteSpecial
End If
Next i
End Sub

Source: Copy rows to other sheet if cell value is greater than zero - OzGrid Free Excel/VBA Help Forum

Any thoughts will be much appreciated.

 

[Fluff]

What is the last used column & do you have a header row in row 1?

 

[unknownymous]

What is the last used column & do you have a header row in row 1?

Yes, I have a header which is on the first Row. Last used column is V.

 

[Fluff]

Thanks for that, how about

Sub unknownymous()
   Dim Ary As Variant, Nary As Variant
   Dim R As Long, i As Long, NxtCol As Long

   Ary = Range("R2:R" & Range("B" & Rows.Count).End(xlUp).Row).Value2
   ReDim Nary(1 To UBound(Ary), 1 To 1)
   For R = 1 To UBound(Ary)
      If Ary(R, 1) = "" Or Ary(R, 1) = 0 Then
         Nary(R, 1) = 1
         i = i + 1
      End If
   Next R
   If i > 0 Then
      Application.ScreenUpdating = False
      With Range("A2").Resize(UBound(Nary), 23)
         .Columns(23).Value = Nary
         .Sort .Columns(23), xlAscending, , , , , , xlNo
         .Resize(i).EntireRow.Delete
      End With
   End If
End Sub

 

[unknownymous]

Thanks for that, how about

Sub unknownymous()
   Dim Ary As Variant, Nary As Variant
   Dim R As Long, i As Long, NxtCol As Long

   Ary = Range("R2:R" & Range("B" & Rows.Count).End(xlUp).Row).Value2
   ReDim Nary(1 To UBound(Ary), 1 To 1)
   For R = 1 To UBound(Ary)
      If Ary(R, 1) = "" Or Ary(R, 1) = 0 Then
         Nary(R, 1) = 1
         i = i + 1
      End If
   Next R
   If i > 0 Then
      Application.ScreenUpdating = False
      With Range("A2").Resize(UBound(Nary), 23)
         .Columns(23).Value = Nary
         .Sort .Columns(23), xlAscending, , , , , , xlNo
         .Resize(i).EntireRow.Delete
      End With
   End If
End Sub

Thanks for this Fluff. I missed something in my scenario. I need to pivot first Sheet 1 since there is repetitive accounts (get sum change). Column to pivot is R (value) and column E as Account Name.

Once the data is ready, the macro will check account name based on values: Let's say we have Pivoted tab Sheet
Step 1: Macro will check names with positive change and lookup the names in Sheet 1 and copy the data in Sheet 3.
Step 2: Macro will check names with negative change and lookup the names in Sheet 1 and copy the data in Sheet 4.

It's kinda bizaare but appreciate the your insight.

 

[Fluff]

That has absolutely nothing to do with your original question, which was about speeding the deleting of rows which were 0 or blank.

 

[unknownymous]

That has absolutely nothing to do with your original question, which was about speeding the deleting of rows which were 0 or blank.

I was able to sort it out. Thanks a lot for your help.

 

[Fluff]

Glad you sorted it & thanks for the feedback.