If cell value = something, then cut row and paste to next sheet

Rackette

New Member
Joined
Jul 2, 2019
Messages
37
Good afternoon and thank you for any help or advise.

I am trying to look through a dynamic range in column B and, where the column B value has a 2nd character = "E", then cut that entire row and paste it on to the next sheet.
There will be many times that column B will match my criteria, so the second worksheet's range will grow as more rows are removed from the first worksheet and pasted on to the 2nd one.

The value in B will look like: 6B230L, 5E431U, 6E226L, 6D537L...

In this example, I would need to cut the row with 5E431U and the row with 6E226L and paste them on to worksheet 2 and then continue looking through column B, doing the same type of thing, until I reach the bottom of the sheet.

I have seen may other macros that ALMOST do what I need, but the one that came closest didn't delete the blank row from the first sheet. It didn't actually cut the row, it just moved the data, I think.

-Christine
 

Some videos you may like

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
2,772
Office Version
365, 2019, 2016
Platform
Windows
How about this. It assumes that your main sheet is sheet1 and the sheet to be copied to is sheet2.

Code:
Sub MXL201907201()
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2")
Dim AR() As Variant: AR = ws1.UsedRange
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim DA As Object: Set DA = CreateObject("System.Collections.ArrayList")


For i = LBound(AR) + 1 To UBound(AR)
    If Mid(AR(i, 2), 2, 1) = "E" Then
        AL.Add Application.Index(AR, i, 0)
        DA.Add i
    End If
Next i


ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(AL.Count, UBound(Application.Transpose(AL.toarray), 1)).Value = Application.Transpose(Application.Transpose(AL.toarray))


For j = DA.Count - 1 To 0 Step -1
    ws1.Rows(DA(j)).Delete
Next j


End Sub
 

Rackette

New Member
Joined
Jul 2, 2019
Messages
37
Thank you for taking the time to help. I really appreciate it.
When I run the code, I get a run-time error. Automation error and the debug shows this line in yellow: Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
 

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
2,772
Office Version
365, 2019, 2016
Platform
Windows
***Posted wrong code
 
Last edited:

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
2,772
Office Version
365, 2019, 2016
Platform
Windows
Ok, give this a shot.

Code:
Sub MXL201907201()
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2")
Dim AR() As Variant: AR = ws1.UsedRange
Dim cnt As Long: cnt = 0
Dim AL() As Variant
Dim DA() As Variant

For i = LBound(AR) + 1 To UBound(AR)
    If Mid(AR(i, 2), 2, 1) = "E" Then
        ReDim Preserve AL(0 To cnt)
        ReDim Preserve DA(0 To cnt)
        AL(cnt) = Application.Index(AR, i, 0)
        DA(cnt) = i
        cnt = cnt + 1
    End If
Next i

ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(AL) + 1, UBound(AL()(0), 1)).Value = Application.Transpose(Application.Transpose(AL))

For j = UBound(DA) To 0 Step -1
    ws1.Rows(DA(j)).Delete
Next j

End Sub
 

Rackette

New Member
Joined
Jul 2, 2019
Messages
37
Again, thank you for taking the time to help me.

I'm getting a run-time error again, but it's now happening at this line:

ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(AL) + 1, UBound(AL()(0), 1)).Value = Application.Transpose(Application.Transpose(AL))

It is a run-time error 5; Invalid procedure call or argument.
 

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
2,772
Office Version
365, 2019, 2016
Platform
Windows
Not sure why you are getting those errors. Both codes work fine on my test data. What version of Excel are you using?

Try this.

Code:
Sub MXL201907203()
Application.ScreenUpdating = False
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2")
Dim AR() As Variant: AR = ws1.UsedRange
Dim cnt As Long: cnt = 0
Dim AL() As Variant
Dim LR As Long: LR = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1

For i = UBound(AR) To 1 Step -1
    If Mid(AR(i, 2), 2, 1) = "E" Then
        ReDim Preserve AL(0 To cnt)
        AL(cnt) = Application.Index(AR, i, 0)
        ws1.Rows(i).Delete
        cnt = cnt + 1
    End If
Next i

For j = 0 To UBound(AL)
    For k = 1 To UBound(AL()(0), 1)
        ws2.Cells(LR, k) = AL()(j)(k)
    Next k
    LR = LR + 1
Next j

Application.ScreenUpdating = True
End Sub
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
42,721
Office Version
365
Platform
Windows
How about
Code:
Sub Rackette()
   With Sheets("Sheet1")
      .Range("A1").AutoFilter 2, "?E*"
      .AutoFilter.Range.Offset(1).EntireRow.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
      .AutoFilter.Range.Offset(1).EntireRow.Delete
      .AutoFilterMode = False
   End With
End Sub
 

Rackette

New Member
Joined
Jul 2, 2019
Messages
37
Hmmm...if these work for both of you, then I'm going to assume that I'm the one doing something wrong. I'm using Office 365.
Fluff, I don't get any errors with your code, but it doesn't seem to do anything to my data. It runs, but nothing gets cut or pasted or changed in any way that I can see. Certainly nothing is being pasted to the second sheet.
Irobbo, I'm getting another run-time error 9, Subscript out of range with your most recent code at this line: For j = 0 To UBound(AL)
I am saving these in my Personal macro workbook. Is that what I'm supposed to be doing?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
42,721
Office Version
365
Platform
Windows
Do you have a header in row 1 with data starting in A2?
Also the workbook containing the data needs to be the active workbook, when running the code.
 

Watch MrExcel Video

Forum statistics

Threads
1,102,455
Messages
5,487,000
Members
407,575
Latest member
calc

This Week's Hot Topics

Top