VBA Copy macro not pasting onto another worksheet

[papa8]

Hi, first time poster here.

I have cobbled together a script (from other sources originally) that selects row(s) containing a tick in column E (Marlett Font 'A' character) copy this/these row(s) and paste it/them into the first empty row(s) in another sheet. The script behaves almost as expected however it is selecting the 'ticked' row and pasting it multiple times rather than just once in certain cases. I haven't truly figured out why it pastes the row more than once but how many times it does paste the row seems to depend on how many non-ticked rows there are.

FYI: I do not need the entire row (just columns B:K) and have read there are other ways to achieve what I want for example - copy as an array, assign the cells directly (which I also tried).

Any help with the error in my script would be really appreciated. A couple of lines are commented out as they were interfering with pasting anything at all at an earlier stage of debugging. There are 4 sheets that this script looks through and I have inefficiently repeated the code four times over.

Sub CopyRows()


Dim matchRow, Cell, LRow As Single
ScreenUpdating = False


For Each ws In Worksheets
ws.Unprotect "rdp"
Next


With Sheets("QChecklist1")
    ActiveSheet.Unprotect "rdp"
    For Each Cell In ActiveSheet.Range("E8:E34")
        If Cell.Value = "a" Then
            matchRow = Cell.Row
            Rows(matchRow & ":" & matchRow).Select
            Selection.Copy
            Sheets("QAnalysisForm").Select
            LRow = Range("B" & Rows.Count).End(xlUp).Row + 1
            ActiveSheet.Rows(LRow).Select
            Selection.PasteSpecial Paste:=xlPasteValues
            Sheets("QChecklist1").Select
            Cells(1, 1).Select
        End If
    Next
    ActiveSheet.Protect "rdp"
End With


With Sheets("QChecklist2")
    ActiveSheet.Unprotect "rdp"
    For Each Cell In ActiveSheet.Range("E8:E34")
        If Cell.Value = "a" Then
            matchRow = Cell.Row
            Rows(matchRow & ":" & matchRow).Select
            Selection.Copy
            Sheets("QAnalysisForm").Select
            LRow = Range("B" & Rows.Count).End(xlUp).Row + 1
            ActiveSheet.Rows(LRow).Select
            Selection.PasteSpecial Paste:=xlPasteValues
            Sheets("QChecklist2").Select
            Cells(1, 1).Select
        End If
    Next
    ActiveSheet.Protect "rdp"
End With


With Sheets("QChecklist3")
    ActiveSheet.Unprotect "rdp"
    For Each Cell In ActiveSheet.Range("E8:E34")
        If Cell.Value = "a" Then
            matchRow = Cell.Row
            Rows(matchRow & ":" & matchRow).Select
            Selection.Copy
            Sheets("QAnalysisForm").Select
            LRow = Range("B" & Rows.Count).End(xlUp).Row + 1
            ActiveSheet.Rows(LRow).Select
            Selection.PasteSpecial Paste:=xlPasteValues
            Sheets("QChecklist1").Select
            Cells(1, 1).Select
        End If
    Next
    ActiveSheet.Protect "rdp"
End With


With Sheets("QChecklist4")
    ActiveSheet.Unprotect "rdp"
    For Each Cell In ActiveSheet.Range("E8:E34")
        If Cell.Value = "a" Then
            matchRow = Cell.Row
            Rows(matchRow & ":" & matchRow).Select
            Selection.Copy
            Sheets("QAnalysisForm").Select
            LRow = Range("B" & Rows.Count).End(xlUp).Row + 1
            ActiveSheet.Rows(LRow).Select
            Selection.PasteSpecial Paste:=xlPasteValues
            Sheets("QChecklist4").Select
            Cells(1, 1).Select
        End If
    Next
    ActiveSheet.Protect "rdp"
End With


Sheets("QAnalysisForm").Activate
Sheets("QAnalysisForm").Protect "rdp"
Cells(1, 1).Select


'On Error Resume Next
'ActiveSheet.CheckBoxes.Delete
'Selection.FormatConditions.Delete
ScreenUpdating = True


For Each ws In Worksheets
        ws.Protect "rdp"
        ws.EnableSelection = xlUnlockedCells
    Next
End Sub

 

[Yongle]

Replace

        If Cell.Value = "a" Then
            matchRow = Cell.Row
            Rows(matchRow & ":" & matchRow).Select
            Selection.Copy
            Sheets("QAnalysisForm").Select
            LRow = Range("B" & Rows.Count).End(xlUp).Row + 1
            ActiveSheet.Rows(LRow).Select
            Selection.PasteSpecial Paste:=xlPasteValues
            Sheets("QChecklist1").Select
            Cells(1, 1).Select
        End If

with

        If cell.Value = "a" Then
            Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)
            Rows(cell.Row).Resize(, 10).Offset(, 1).Copy cel2
            cel2.Value = cel2.Value
        End If

and declare cel2 as a range


As you can see, there is no need to select cells in VBA

 

[Yongle]

Welcome to the forum
I had intended to explain the code to you

find last cell in column and offset down 1 row (cel2)
Set cel2 = Sheets("QAnalysisForm").Range("B" & Rows.Count).End(xlUp).Offset(1)

take the entire row \ resize it to 10 columns (now is A:J) \ and offset by 1 column to right (now is B:K)
Rows(cell.Row).Resize(, 10).Offset(, 1)

copy that row to cel2
Rows(cell.Row).Resize(, 10).Offset(, 1).Copy cel2

this turns formula into values
cel2.Value = cel2.Value

I prefer this method to pasting values because formatting is maintained by the original paste to cel2

 

[bobsan42]

try to clear your code a bit and avoid selection if not absolutely necessary. Try to replace this:

...
With Sheets("QChecklist1")
    ActiveSheet.Unprotect "rdp"
    For Each Cell In ActiveSheet.Range("E8:E34")
        If Cell.Value = "a" Then
            matchRow = Cell.Row
            Rows(matchRow & ":" & matchRow).Select
            Selection.Copy
            Sheets("QAnalysisForm").Select
            LRow = Range("B" & Rows.Count).End(xlUp).Row + 1
            ActiveSheet.Rows(LRow).Select
            Selection.PasteSpecial Paste:=xlPasteValues
            Sheets("QChecklist1").Select
            Cells(1, 1).Select
        End If
    Next
    ActiveSheet.Protect "rdp"
End With
...

with this:

...
dim wsh as Worksheet: set wsh = Sheets("QAnalysisForm")
With Sheets("QChecklist1")
    .Unprotect "rdp" 
    For Each Cell In .Range("E8:E34")
        If Cell.Value = "a" Then
            Cell.Entirerow.copy
            wsh.Range("B" & wsh.Rows.Count).End(xlUp).Offset(1).EntireRow.PasteSpecial xlPasteValues
        End If
    Next
    .Protect "rdp"
End With
....

or something along these lines.

 

[papa8]

Bobsan42, Yongle, Many thanks for helping clear that up. I noticed the formatting not staying consistent myself. I will look at both solutions in work tomorrow. Love learning and being able to have the actual code you are working on explained helps!

 

[papa8]

Hi, both solutions will work above for most people. I realised however (from looking at the approach of each solution above) that I had used Activesheet.Range in my 'For' iterative loop so the first solution that only replaced the If..Then conditional loop meant that it still selected the same 'ticked' row four times over (since I had used ActiveSheet in each of my 4 For loops in my module). The second solution is what got me to see that the '.Range' in the 'For' loop inside the 'With' statements was all I needed to change. Due to merged cells in my source worksheets the second solution threw an error as an entire row will be a different size to where it gets pasted. If there were no merged cells then the solution would work flawlessly. Taking an entire row has a long-term advantage over the precise B:K range since it will allow for new columns to be included in the future and not break the functionality of the copy and paste.

Learnt a lot. Many thanks to the contributors for the time they spent explaining and working on a solution for me.