Macro to cut and paste whole rows from one sheet to another

[koliver3]

Hello all,

I have been searching and trying to code a specific macro for a couple of weeks now, and I'm agonisingly close but it falls down at the last hurdle. There seem to be a number of solutions to extremely similar problems on this forum, but none of them works for my specific requirements, and I'm seriously lacking the knowledge to debug and modify what I have to work.

I would very much appreciate someone having a quick look as I'm sure to the trained eye there is a simple error that should be easily rectified to anyone with more knowledge than me!

The brief.

I have a set of data with a decreasing variable. I want to create a macro that searches for a value of "0" in column G of one sheet, then cut the whole row, and then paste the whole row into the first empty row in another sheet in the same workbook.

Here is what I have so far:

Sub Find_Move_Zeros()


Dim LastRow As Long


On Error GoTo GetOut
Do
Range("G7:G10000").Select
Selection.Find(What:="0", After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
n = ActiveCell.Address
        
ActiveCell.EntireRow.Cut


With Sheets("Completed Dedications")
      
     LastRow = .Range("G" & Rows.Count).End(xlUp).Row
 
     .Range("A" & LastRow + 1).PasteSpecial xlPasteValues
     
End With
Sheets("Current Dedications").Activate
Loop
GetOut:
End Sub

It seems to fall down after the "With" Sheets("Completed Dedications")" so I'm suspecting something is wrong with my method of finding and pasting to the next blank row.

Can anyone point me in the right direction please??

Many thanks.

 

[mumps]

Try:

Sub Find_Move_Zeros()
    Application.ScreenUpdating = False
    Dim bottomG As Long
    bottomG = Range("G" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("G1:G" & bottomG).AutoFilter Field:=1, Criteria1:="0"
    ActiveSheet.Range("G7:G" & bottomG).SpecialCells(xlCellTypeVisible).EntireRow.Copy
    Sheets("Completed Dedications").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    ActiveSheet.Range("G2:G" & bottomG).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

The macro assumes there are headers in row 1.

 

[koliver3]

Thanks mumps.

This throws up an error saying the copy and paste destinations are different sizes.

 

[koliver3]

hmmm, I modified for headers incorrectly.

Rectified that issue and now the error is "PasteSpecial method of range class failed"

 

[mumps]

I tried it on some dummy data and it worked properly. Do you have a sheet named "Completed Dedications"?

 

[koliver3]

Yes. The source sheet is called "Current Dedications" and the destination sheet is called "Completed Dedications".

 

[Fluff]

Here is another option

Sub Find_Move_Zeros()

    Dim Ar As Areas
    Dim Rng As Range

    Sheets("Current Dedications").Activate

    With Range("G1:G10000")
        .Replace "0", True, xlWhole
        On Error Resume Next
        Set Ar = .SpecialCells(xlConstants, xlLogical).Areas
        On Error GoTo 0
    End With
        
    With Sheets("Master")  
        For Each Rng In Ar
            .Range("A" & .Range("G" & Rows.Count).End(xlUp).Offset(1).Row).Resize(Rng.Count).EntireRow.Value _
                = Rng.EntireRow.Value
            Rng.EntireRow.Delete
         Next Rng
         .Columns(7).Replace True, "0", xlWhole
    End With

End Sub

 

[mumps]

Make sure that the source sheet is the active sheet when you run the macro. If this still doesn't work, perhaps you could upload a copy of your file to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[koliver3]

Thanks Fluff.

This throws up an "Object Required" error on the command line "For Each Rng In Ar"

 

[koliver3]

Link to file ------> https://www.dropbox.com/s/t7bklpj5q56zjf0/K_Dedication_List_V1.1.xlsm?dl=0

Thanks