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]

The problem is being caused by the merged cells on both sheets where you have "Total Bears". Unmerge those cells and try the macro again. You should avoid merged cells if at all possible because they most often cause problems for Excel macros.

 

[Fluff]

Try

Sub Find_Move_ZerosFluff()


    Dim Ar As Areas
    Dim Rng As Range

    Sheets("Current Dedications").Activate

    With Range("G9", Range("G" & Rows.Count).End(xlUp))
        .Value = Evaluate("if(" & .Address & "= 0, True," & .Address & ")")
        On Error Resume Next
        Set Ar = .SpecialCells(xlConstants, xlLogical).Areas
        On Error GoTo 0
    End With
    
    With Sheets("Completed Dedications")
        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

 

[Fluff]

On second thoughts try this

Sub Find_Move_ZerosFluff()


    Dim Ar As Areas
    Dim Rng As Range

    Sheets("Current Dedications").Activate

    With Range("G9", Range("G" & Rows.Count).End(xlUp))
        .Value = Evaluate("if(" & .Address & "= 0, True," & .Address & ")")
        On Error GoTo Xit
        Set Ar = .SpecialCells(xlConstants, xlLogical).Areas
        On Error GoTo 0
    End With
    
    With Sheets("Completed Dedications")
        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
Exit Sub
Xit:
    MsgBox "No zero values found"
End Sub

 

[koliver3]

Thanks mumps. I've unmerged the cells (I had no idea that would cause macros so much grief.

This works in so much as it copies the cells from the first sheet to the destination sheet; however, it has overwritten the headers. I'm guessing I've got the wrong start points for the pasting and cutting.

The link to the files are here -------> https://www.dropbox.com/s/biov1cfrjqmgq6y/K_Dedication_List_V1.1_Rows_Deleted.xlsm?dl=0

Thanks in advance

 

[koliver3]

Thanks Fluff. This solution seems to work very effectively. However, it deletes the formulas in row G in the source sheet. (It's only a simple if formula calculating the bears left, but i need it to remain in the unused cells) Can the code be modified to maintain the formulas please?

 

[mumps]

Try:

Sub Find_Move_Zeros()
    Application.ScreenUpdating = False
    Dim bottomG As Long
    bottomG = Range("G" & Rows.Count).End(xlUp).Row
    Dim bottomB As Long
    bottomB = Sheets("Completed Dedications").Range("B" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("G3:G" & bottomG).AutoFilter Field:=1, Criteria1:="0"
    ActiveSheet.Range("B7:I" & bottomG).SpecialCells(xlCellTypeVisible).Copy
    If bottomB < 4 Then
        bottomB = 4
        Sheets("Completed Dedications").Cells(bottomB, 2).PasteSpecial xlPasteValues
    End If
    ActiveSheet.Range("G4:G" & bottomG).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[Fluff]

Thanks Fluff. This solution seems to work very effectively. However, it deletes the formulas in row G in the source sheet. (It's only a simple if formula calculating the bears left, but i need it to remain in the unused cells) Can the code be modified to maintain the formulas please?

Almost certainly yes, but unfortunately I can't figure how.

 

[Fluff]

A slightly different approach

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)
        .Value = Evaluate("if(" & .Offset(, 6).Address & "= 0,true,"""")")
        On Error GoTo Xit
        Set Ar = .SpecialCells(xlConstants, xlLogical).Areas
        On Error GoTo 0
    End With
    
    With Sheets("Completed Dedications")
        For Each Rng In Ar
            .Range("B" & .Range("G" & Rows.Count).End(xlUp).Offset(1).Row).Resize(Rng.Count, 8).Value _
                = Rng.Offset(, 1).Resize(, 8).Value
            Rng.EntireRow.Delete
         Next Rng
    End With

Exit Sub

Xit:
    MsgBox "No zero values found"

End Sub

 

[koliver3]

Thanks for your help, this now works a treat, really appreciate your input.

Mumps, with my limited knowledge I can walk myself through your code I think.
Fluff, your code might as well be greek for all I can understand.
Can you comment it or walk me through it so I can better understand why it works please?

Many thanks again.

 

[mumps]

You are very welcome.