Copying data to another sheet

[Damo10]

Hi,

I have 4 sheets that I would like to copy some data from and put it in a sheet called Data, each sheet has approx 1800 rows.

I would like the macro to look at each row and if the value of cells CQ and CU are greater than 0 copy the data from cells CP:DA of that row and paste them onto sheet Data in the next empty row starting from row 2
It would then do this for the next 3 sheets, the sheets are called "22", "25", "26", "Names"

Regards

 

[kpark91]

Hi, Damo10
I haven't tested this code but I think it will error at copying in copyFunc function but please let me know

Sub CopyAll()
    Dim LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long, count As Long, i As Long
    LR1 = Worksheets("22").Range("A" & Rows.count).End(xlUp).Row
    LR2 = Worksheets("25").Range("A" & Rows.count).End(xlUp).Row
    LR3 = Worksheets("26").Range("A" & Rows.count).End(xlUp).Row
    LR4 = Worksheets("Names").Range("A" & Rows.count).End(xlUp).Row
    
    count = 2
    count = copyFunc("22", LR1, count)
    count = copyFunc("25", LR2, count)
    count = copyFunc("26", LR3, count)
    count = copyFunc("Names", LR4, count)
    
End Sub

Function copyFunc(strWS As String, LR As Long, count As Long) As Long
    For i = 2 To LR
        If Worksheets(strWS).Range("CQ" & i).Value > 0 And Worksheets(strWS).Range("CU" & i).Value > 0 Then
            Worksheets(strWS).Range("CP" & i & ":" & "DA" & i).Copy Worksheets("Data").Range("A" & count)
            count = count + 1
        End If
    Next i
    copyFunc = count
End Function

 

[Damo10]

Hi,

Thanks for reply

I have tested the code and it is filling all the cells on the Data sheet that it copys with =#REF!

Regards

 

[kpark91]

Try

Sub CopyAll()
    Dim LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long, count As Long, i As Long
    LR1 = Worksheets("22").Range("A" & Rows.count).End(xlUp).Row
    LR2 = Worksheets("25").Range("A" & Rows.count).End(xlUp).Row
    LR3 = Worksheets("26").Range("A" & Rows.count).End(xlUp).Row
    LR4 = Worksheets("Names").Range("A" & Rows.count).End(xlUp).Row
    
    count = 2
    count = copyFunc("22", LR1, count)
    count = copyFunc("25", LR2, count)
    count = copyFunc("26", LR3, count)
    count = copyFunc("Names", LR4, count)
    
End Sub

Function copyFunc(strWS As String, LR As Long, count As Long) As Long
    For i = 2 To LR
        If Worksheets(strWS).Range("CQ" & i).Value > 0 And Worksheets(strWS).Range("CU" & i).Value > 0 Then
            Worksheets(strWS).Range("CP" & i & ":" & "DA" & i).Copy
            Worksheets("Data").Range("A" & count).PasteSpecial xlPasteValues
            count = count + 1
        End If
    Next i
    copyFunc = count
End Function

Just as a verification, did you have formulas in the cells you wanted to copy?

 

[Damo10]

That works great, thanks a lot