Copy Paste loop with Criteria

[RoganLogan]

Hi,

I am trying to copy some data from sheet 3 of my workbook and then paste it on sheet 2 with two criteria. The criteria being that some text in Cell A10 of sheet 3 must match the text in Column B of sheet 2 and that a date in Cell BI1 of sheet3 matches the date in Column C of sheet2. I then need to paste the data in the next column D.

i've had a go at making a loop below and although it does seem to loop through the data trying to match the both the text and date it just however pastes the data in the last cell I have clicked on in sheet2. Not sure if I am approaching the problem correctly but any help would be greatly appreciated.

Sub Move_DA_Forecast()Dim Sheet2 As Worksheet
Dim PV As Worksheet
Set Sheet2 = ThisWorkbook.Sheets("Sheet2")
Set Sheet3 = ThisWorkbook.Sheets("Sheet3")


    Sheets("Sheet3").Select
    Range("B10").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Sheet2").Select


LR = Sheet2.Cells(Rows.Count, 3).End(xlUp).Row
PVEXC = Sheet3.Cells(10, 1)
DA = Sheet3.Cells(1, 61)


'loop
For x = 5 To LR
    If Sheet2.Cells(x, 3) = DA And Sheet2.Cells(x, 2) = PVEXC Then
    ActiveCell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
    
End If
    
    
Next x


End Sub

Thanks for your time.

 

[Leith Ross]

Hello RoganLogan,

Give this version a try.

Sub Move_DA_Forecast()


    Dim Cell    As Range
    Dim Row     As Long
    Dim rngDst  As Range
    Dim rngEnd  As Range
    Dim rngSrc  As Range
    Dim Wks2    As Worksheet
    Dim Wks3    As Worksheet
    
        Set Wks2 = ThisWorkbook.Sheets("Sheet2")
        Set Wks3 = ThisWorkbook.Sheets("Sheet3")


        Set rngSrc = Wks3.Range("B10")
        Set rngEnd = Wks3.Cells(Rows.Count, "B").End(xlUp)
        If rngEnd.Row < rngSrc.Row Then Exit Sub
        
        Set rngSrc = Wks3.Range(rngSrc, rngEnd)
        PVEXC = Wks3.Cells(10, "A")
        DA = Wks3.Cells(1, "BI")
        
        Set dstRng = Wks2.Range("C5")
        Set rngEnd = Wks2.Cells(Rows.Count, "C").End(xlUp)
        If rngEnd.Row < dstRng.Row Then Exit Sub
        
        Set rngDst = Wks2.Range(rngDst, rngEnd)
        
        'loop
        For Each Cell In dstRng.Cells
            If Cell = DA And Cell.Offset(0, 1) = PVEXC Then
                Row = Row + 1
                Cell.Offset(0, 1).Value = rngSrc.Cells(Row, 1).Value
            End If
        Next Cell
        
End Sub

 

[RoganLogan]

Hi Leith,

Thanks for your help. I have tried to run that code but it is giving me a Run time error 1004 with the description of Method 'Range' of object '_Worksheet' failed and then when I debug it highlights this row of code, Set rngDst = Wks2.Range(rngDst, rngEnd)

Not sure what the error is as my vba is basic to say the least. Any suggestions?

Again thanks for any additional help.

RL

 

[Fluff]

There's a typo in Leith Ross' code.
This

Set dstRng = Wks2.Range("C5")

should be

Set [COLOR=#0000ff]rngDst [/COLOR]= Wks2.Range("C5")

 

[RoganLogan]

Hi Fluff,

Just tried correcting that variable but still get the same error run time error 1004 with the description of Method 'Range' of object '_Worksheet' failed and it still highlights the same row of code, Set rngDst = Wks2.Range(rngDst, rngEnd). I spotted another typo with the same variable but still get the same run time error. Thanks for any help received.

RL

 

[Fluff]

I noticed 2 further typos for that variable, not sure which you spotted. Try

        Set rngDst = Wks2.Range("C5")
        Set rngEnd = Wks2.Cells(Rows.Count, "C").End(xlUp)
        If rngEnd.Row < rngDst.Row Then Exit Sub
        
        Set rngDst = Wks2.Range(rngDst, rngEnd)
        
        'loop
        For Each Cell In rngDst.Cells

 

[Leith Ross]

Hello RoganLogan,

Try this rewrite of the macro. This has been checked for typos.

Sub Move_DA_Forecast()


    Dim Cell    As Range
    Dim DA      As Variant
    Dim PVEXC   As Variant
    Dim Row     As Long
    Dim rngDst  As Range
    Dim rngEnd  As Range
    Dim rngSrc  As Range
    Dim Wks2    As Worksheet
    Dim Wks3    As Worksheet
    
        Set Wks2 = ThisWorkbook.Sheets("Sheet2")
        Set Wks3 = ThisWorkbook.Sheets("Sheet3")


        Set rngSrc = Wks3.Range("B10")
        Set rngEnd = Wks3.Cells(Rows.Count, "B").End(xlUp)
        If rngEnd.Row < rngSrc.Row Then Exit Sub
        
        Set rngSrc = Wks3.Range(rngSrc, rngEnd)
        PVEXC = Wks3.Cells(10, "A")
        DA = Wks3.Cells(1, "BI")
        
        Set rngDst = Wks2.Range("C5")
        Set rngEnd = Wks2.Cells(Rows.Count, "C").End(xlUp)
        If rngEnd.Row < rngDst.Row Then Exit Sub
        
        Set rngDst = Wks2.Range(rngDst, rngEnd)
        
        'loop
        For Each Cell In rngDst.Cells
            If Cell = DA And Cell.Offset(0, 1) = PVEXC Then
                Row = Row + 1
                Cell.Offset(0, 1).Value = rngSrc.Cells(Row, 1).Value
            End If
        Next Cell
        
End Sub

 

[RoganLogan]

Hi Leith,

Thanks for your efforts. The code does run now but doesn't copy and paste the rows that I want to transfer from sheet 3 to sheet 2. Forgive my ignorance but which section of your code refers to the copy and paste process.

Thanks,

LR

 

[Leith Ross]

Hello RoganLogan,

In your original post, you are only copying the values from Sheet3 to Sheet2 viz...

ActiveCell.Offset(0, 1).PasteSpecial Paste:=xlPasteValues

I have changed my code to do a Copy and Paste all of the cells' formats. If you only want specific formatting pasted then let me know so I can change the code.

Option Explicit


Sub Move_DA_Forecast()


    Dim Cell    As Range
    Dim cSize   As Long
    Dim DA      As Variant
    Dim PVEXC   As Variant
    Dim Row     As Long
    Dim rngDst  As Range
    Dim rngEnd  As Range
    Dim rngSrc  As Range
    Dim Wks2    As Worksheet
    Dim Wks3    As Worksheet
    
        Set Wks2 = ThisWorkbook.Sheets("Sheet2")
        Set Wks3 = ThisWorkbook.Sheets("Sheet3")


        Set rngSrc = Wks3.Range("B10")
        Set rngEnd = Wks3.Cells(Rows.Count, "B").End(xlUp)
        If rngEnd.Row < rngSrc.Row Then Exit Sub
        
        Set rngSrc = Wks3.Range(rngSrc, rngEnd)
        PVEXC = Wks3.Cells(10, "A")
        DA = Wks3.Cells(1, "BI")
        
        Set rngDst = Wks2.Range("C5")
        Set rngEnd = Wks2.Cells(Rows.Count, "C").End(xlUp)
        If rngEnd.Row < rngDst.Row Then Exit Sub
        
        Set rngDst = Wks2.Range(rngDst, rngEnd)
        
        'loop
        For Each Cell In rngDst.Cells
            If Cell = DA And Cell.Offset(0, 1) = PVEXC Then
                Row = Row + 1
                ' Get the width of the columns to copy and paste.
                cSize = (rngSrc.Cells(Row, 1).End(xlToRight).Column) - rngSrc.Column + 1
                ' Copy the source cells.
                rngSrc.Cells(Row, 1).Resize(1, cSize).Copy
                ' Paste them to the destination.
                Cell.Offset(0, 1).Resize(1, cSize).PasteSpecial Paste:=xlPasteAll
            End If
        Next Cell
        
End Sub

 

[RoganLogan]

Hi Leith,

Thanks very much for this! After adjusting a few things i got it to work with my spreadsheet, it works really well and quick. However what i wanted to be able to do was copy and paste not just the data in sheet 3 starting at cell B10 but also B11 and B12. So in my original code I did xlDown and xlRight from cell B10.

In your code the line

cSize = (rngSrc.Cells(Row, 1).End(xlToRight).Column) - rngSrc.Column + 1

gets the line of data for B10 but how can i get it to copy the two rows below. I tried to add xlDown but I must be putting in the wrong place.

Thanks again.

RL