Cut, Paste, Delete based on values from a list

[Lovelylou79]

Hi Excel Community,

Long time code thief, first time poster....

I'm looking for assistance with Cutting, Pasting and Deleting rows from Sheet 1 to Sheet 3 ("#PRU"), based on a list of values from Sheet 2 ("Codes").

I have investigated several codes from this and other forums, however I can not seem to make them fit my exact purposes.

The closest I have come is the following, which bugs out at the "Insert" line;

Sub cutrows()
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "#PRU"
Dim d As Object, e, rws&, cls&, i&, j&
Set d = CreateObject("scripting.dictionary")
For Each e In Sheets("Codes").Range("A1").CurrentRegion
d(e.Value) = 1
Next e
Sheets("Phish").Activate
rws = Cells.Find("*", After:=[a1], searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row
cls = Cells.Find("*", After:=[a1], searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
For i = rws To 1 Step -1
For j = 1 To cls
If d(Range("A1").Resize(rws, cls)(i, j).Value) = 1 Then _
Cells.Rows(i).Cut Sheets("#PRU").Range("1:1").EntireRow.Insert: Exit For
Next j, i
End Sub

This code was originally intended for deleting the rows, I have tried to manipulate it to cut and paste. Ideally the row would be deleted once the cut/paste function is completed.

Any assistance would be greatly appreciated.

 

[dmt32]

Hi,
welcome to forum.

Not fully tested but give following a try & see if it goes in right direction for you

Sub CopyDeleteRows()
    Dim c As Range, CopyRange As Range, DataRange As Range
    Dim DestRange As Range
    Dim arr As Variant
    Dim wsPRU As Worksheet


    With ThisWorkbook
        With .Sheets("Codes")
'values to copy - change range as required
            arr = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp)).Value
        End With
        With .Sheets("Phish")
'copy sheet 1
            Set DataRange = .Range(.Range("A2"), .Range("A" & .Rows.Count).End(xlUp))
        End With


    On Error Resume Next
    Set wsPRU = .Worksheets("#PRU")
    If Err.Number = 9 Then
'if sheet does not exist create it
        Set wsPRU = .Worksheets.Add(after:=.Worksheets(.Sheets.Count))
        wsPRU.Name = "#PRU"
    Else
'optional
         wsPRU.Cells.Clear
    End If
    End With
    
    On Error GoTo 0
    
'copy destination
    Set DestRange = wsPRU.Range("A1")
    
    For Each c In DataRange.Cells
        m = Application.Match(c.Value, arr, False)
        If Not IsError(m) Then
            If CopyRange Is Nothing Then
                Set CopyRange = c
            Else
                Set CopyRange = Union(CopyRange, c)
            End If
        End If
    Next c
    
    If Not CopyRange Is Nothing Then
        With CopyRange.EntireRow
            .Copy DestRange
            .Delete shift:=xlShiftUp
        End With
    End If


End Sub

Note: I have assumed that list values are in column 1 (A) of your codes sheet & the same for the search range in sheet 1 ("Phish") you will need to adjust as required.

Always make a back-up of your workbook before testing new code.

Hope Helpful

Dave

 

[Lovelylou79]

Thank you so much Dave, this works perfectly!

 

[dmt32]

Thank you so much Dave, this works perfectly!

you are welcome - many thanks for feedback

Dave