Vba: cut and paste entire rows (out of memory)

[Nelson78]

Hello everybody.

I'm dealing with a big amount of datas, about 40k rows.

I need to cut and paste entire rows from a sheet to another, if conditions are not checked.

Example: cut and copy in the sheet Beta if in column A of sheet Alpha <> 36 characters

Assuming - but I'm not sure - that the following code is correct, I bump into a Run-time error '7': Out of memory

    Dim i As Long
    
    For i = Sheets("Alpha").Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
        If Len(Cells.Value) <> 36 Then
            Sheets("Alpha").Range("A" & i).Copy Sheets("Beta").Cells(Rows.Count, 1).End(xlUp).Offset(1)
            Cells(i, 1).EntireRow.Delete
        End If
    Next

How can I manage this deadlock?

 

[Joe4]

Maybe try a different approach.
Like, create a helper column that returns the length of each row.
Then, use Filters on this helper field to identify and move the records you want.
You can use Filters within VBA too, if desired.

 

[Fluff]

Assuming you have a header row in row1 with data starting row 2, try

Sub FltrDel()
   With Sheets("Alpha")
      If .AutoFilterMode Then .AutoFilterMode = False
      Range("A1").AutoFilter 10, "<>" & String(36, Chr(63))
      .UsedRange.Offset(1).SpecialCells(xlVisible).EntireRow.Delete
      .AutoFilterMode = False
   End With
End Sub

 

[Nelson78]

With the following I've create the column (J): the row with "KO" in column J must be transfered from sheet Alpha to sheet Beta.
I'm going to try.

For Each c In Range("A2:A" & lr)
    If Len(c.Value) <> 36 Then c.Offset(0, 10).Value = "KO"
Next

 

[Nelson78]

Errata corrige: the new column is K, not J.

 

[Joe4]

Loops are extremely slow and inefficient, so I don't know if that is going to be any better.
Consider using one of the Filter options we suggested.

 

[Nelson78]

Uhm...
so, I'm going to try filtering the new helper column K.

 

[Joe4]

You don't need a loop to populate that column (avoid using loops whenever possible, that is kind of what got you in this mess).
Just do it like this:

    Range("K2:K" & lr).FormulaR1C1 = "=IF(LEN(RC[-10])<>36,""KO"","""")"

 

[Fane Duru]

Assuming you have a header row in row1 with data starting row 2, try

Sub FltrDel()
   With Sheets("Alpha")
      If .AutoFilterMode Then .AutoFilterMode = False
      Range("A1").AutoFilter 10, "<>" & String(36, Chr(63))
      .UsedRange.Offset(1).SpecialCells(xlVisible).EntireRow.Delete
      .AutoFilterMode = False
   End With
End Sub

Brilliant!
Unfortunately, people could not understand its beauty/compactness...
Resizing as

.UsedRange.Resize(.UsedRange.rows.count - 1).Offset(1).SpecialCells(xlVisible).EntireRow.Delete

will avoid deleting an extra empty row, but this does not matter too much. I use VBA from some years now, but I could not think of that trick of building a string of question marks (to replace each existing character) as criteria.
Really brilliant, at least, on my taste...