Button with Macro that copies and pastes row into new sheet if cell has a certain value

[06grayl]

I need help with my macro. I've got a table of data A1:R35 in sheet "Active" and when the value in column R is 100% and you press this button I want it to copy and paste that whole row into the next available row in sheet "Completed".

Here is my current Macro:

Private Sub CommandButton1_Click()


Application.ScreenUpdating = False
Dim score As Integer
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet


Set copySheet = Worksheets("Active")
Set pasteSheet = Worksheets("Completed")


score1 = Range("R1").Value


If score1 = 100% Then


copySheet.Range("A2:R2").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, SkipBlanks:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True


Sheets("Active").Range("A2:R2") = ""

score2 = Range("R2").Value

If score2 = 100% Then


copySheet.Range("A3:R3").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues, SkipBlanks:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True


Sheets("Active").Range("A2:R2") = ""

*This repeated 35 times etc, their must be a better way and one that works?*


End If


End Sub

Is their a better way to do this that doesn't require 35 copies and this current If statement doesn't seem to work either

Any help would be much appreicated

 

[Max1616]

Try this:

Sub CommandButton1_Click()

Application.ScreenUpdating = False
Dim score As Integer
Dim copysheet As Worksheet
Dim pasteSheet As Worksheet
Dim lrow1 As Long
Dim lrow2 As Long
Dim i As Long


Set copysheet = Worksheets("Active")
Set pasteSheet = Worksheets("Completed")

lrow1 = copysheet.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
For i = 2 To lrow1
    If copysheet.Cells(i, 18) = 1 Then
        copysheet.Range("A" & i & ":R" & i).Copy
        lrow2 = pasteSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
        pasteSheet.Cells(lrow2, 1).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
    End If
Next i
Application.ScreenUpdating = True

End Sub

You can loop through each cell instead of writing a separate macro for each cell.

 

[jolivanes]

Try on a copy of your worbook first.
Change references (like the 1) as required.

Sub Maybe()
Application.ScreenUpdating = False
With Sheets("Active").UsedRange
    .AutoFilter 18, 1
    .SpecialCells(12).Copy Sheets("Completed").Range("A1")
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

 

[06grayl]

Try this:

Sub CommandButton1_Click()

Application.ScreenUpdating = False
Dim score As Integer
Dim copysheet As Worksheet
Dim pasteSheet As Worksheet
Dim lrow1 As Long
Dim lrow2 As Long
Dim i As Long


Set copysheet = Worksheets("Active")
Set pasteSheet = Worksheets("Completed")

lrow1 = copysheet.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
For i = 2 To lrow1
    If copysheet.Cells(i, 18) = 1 Then
        copysheet.Range("A" & i & ":R" & i).Copy
        lrow2 = pasteSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
        pasteSheet.Cells(lrow2, 1).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
    End If
Next i
Application.ScreenUpdating = True

End Sub

You can loop through each cell instead of writing a separate macro for each cell.

Thank you so much this has helped massively, I'm trying to switch it to cut and paste instead of copy and paste but can't do it on loop. It won't paste properly if i change to .Cut

 

[jolivanes]

Sub Maybe()
Application.ScreenUpdating = False
With Sheets("Active").UsedRange
    .AutoFilter 18, 1
    .SpecialCells(12).Copy Sheets("Completed").Range("A1")
    .Offset(1).SpecialCells(12).EntireRow.Delete Shift:=xlUp
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

 

[Max1616]

I think this is what you are looking for:

Sub CommandButton1_Click()

Application.ScreenUpdating = False
Dim score As Integer
Dim copysheet As Worksheet
Dim pasteSheet As Worksheet
Dim lrow1 As Long
Dim lrow2 As Long
Dim i As Long


Set copysheet = Worksheets("Active")
Set pasteSheet = Worksheets("Completed")

lrow1 = copysheet.Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
For i = lrow1 To 2 Step -1
    If copysheet.Cells(i, 18) = 1 Then
        copysheet.Range("A" & i & ":R" & i).Copy
        lrow2 = pasteSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
        pasteSheet.Cells(lrow2, 1).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        copysheet.Cells(i, 1).EntireRow.Delete
    End If
Next i
Application.ScreenUpdating = True

End Sub