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.

 

[Fluff]

Glad we could help & thanks for the feedback

Commented code h/w

Sub Find_Move_ZerosFluff()


    Dim Ar As Areas
    Dim Rng As Range

    Sheets("Current Dedications").Activate

    With Range("A9:A" & Range("G" & Rows.Count).End(xlUp).Row)
'    This line is effectively if Col G=0 then return True in Col A else return ""
        .Value = Evaluate("if(" & .Offset(, 6).Address & "= 0,true,"""")")  '
        On Error GoTo Xit
'    Set an area equal to all cells in Col A that contain a logical value (ie = True)
        Set Ar = .SpecialCells(xlConstants, xlLogical).Areas
        On Error GoTo 0
    End With
    
    With Sheets("Completed Dedications")
'    Loop through each range in Ar
        For Each Rng In Ar
'    Set the location for data to be copied to & then copy
            .Range("B" & .Range("G" & Rows.Count).End(xlUp).Offset(1).Row).Resize(Rng.Count, 8).Value _
                = Rng.Offset(, 1).Resize(, 8).Value
'    delete the range from original sheet
            Rng.EntireRow.Delete
         Next Rng
    End With

Exit Sub

Xit:
    MsgBox "No zero values found"

End Sub

' For your test data the evaluate will return True in A9:A13 & A15:A16
' On the first pass through the loop. Rng =A9:A13
' .Range("B" & .Range("G" & Rows.Count).End(xlUp).Offset(1).Row) gives B4
' .Resize(Rng.Count, 8) gives .resize(5,8)
' so the copy to range is B4 resize(5,8) = B4:I8

 

[koliver3]

Hello Fluff,
The code that you kindly created worked very well on my test data.

I have only just got round to populating the sheet with all of the applicable data, and the macro doesn't like the full sheet, returning the text box as if there were no completed dedications.

Despite the commenting, (thanks for that) I don't understand why it can't see the completed dedications.

Link to file -------> https://www.dropbox.com/s/zodz9n20cp3j8cx/K_Dedication_List_V1.4_Completed Data - Unmoved.xlsm?dl=0

Can you take a look at the macro at your leisure please?

Many thanks.

 

[koliver3]

Panic over, just sorted. I made a modification which I've just gone back and removed and it seems to be working again.

PICNIC - "Problem In Chair, Not In Computer"

 

[Fluff]

PICNIC - "Problem In Chair, Not In Computer"

Im a PANIC man myself.
Problems? Always! Never In Computer