Copy a range of cells in a row based on value in two cells and paste in different sheets

[manojrf]

Hello everyone,

In this forum, I found a macro to copy an entire row based on value and to paste in different sheets. First of all, let me say that I am not an expert in creating macros. I have made some modifications to the original one, added one more criteria.

Sub Copy()
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("LIST").Cells(Rows.Count, "B").End(xlUp).Row
lr2 = Sheets("ABOVE 50000 17-18").Cells(Rows.Count, "B").End(xlUp).Row
lr3 = Sheets("BELOW 50000 17-18").Cells(Rows.Count, "B").End(xlUp).Row
For r = lr To 2 Step -1
If Range("E" & r).Value = "17-18" And Range("D" & r).Value >50000 Then
Rows(r).Copy Destination:=Sheets("ABOVE 50000 17-18").Range("B" & lr2 + 1)
lr2 = Sheets("ABOVE 50000 17-18").Cells(Rows.Count, "B").End(xlUp).Row
End If
If Range("E" & r).Value = "17-18" And Range("D" & r).Value <50000 Then
Rows(r).Copy Destination:=Sheets("BELOW 50000 17-18").Range("B" & lr2 + 1)
lr2 = Sheets("BELOW 50000 17-18").Cells(Rows.Count, "B").End(xlUp).Row
End If
Range("A1").Select
Next r
End Sub


When the macro was run, it used to copy the entire row and paste it to different sheets based on the conditions. It was working fine, until I changed Column A to Column B. In addition to this, I have put a formula in column A in the destination sheets. When I run the macro, it says that the copy area and paste area are not of the same size and so can't paste it. I have tried my best to make it work, but it isn't.

Instead of copying the entire row, can this be modified to copy a range of cells in a row, when the conditions are met ?

Can anyone please help me out ?

LIST

	A	B	C	D	E
1		Number	Name	Amount	Year
2		1234	ABCD	51000	17-18
3		2345	BCDE	45000	17-18
4		3456	CDEF	1000	17-18

<colgroup><col style="font-weight:bold; width:30px; "><col style="width:41px;"><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"></colgroup><tbody>
</tbody>

Excel tables to the web >> Excel Jeanie HTML 4




ABOVE 50000 17-18

	A	B	C	D	E	F
1	Sr.No	Number	Name	Amount	Year
2						1
3						2
4						3

<tbody>
</tbody>

Spreadsheet Formulas

Cell Formula A2 =IF(B2="","",F2) A3 =IF(B3="","",F3) A4 =IF(B4="","",F4) <tbody> </tbody>

<tbody>
</tbody>

BELOW 50000 17-18

	A	B	C	D	E	F
1	Sr.No	Number	Name	Amount	Year
2						1
3						2
4						3

<tbody>
</tbody>

Spreadsheet Formulas

Cell Formula A2 =IF(B2="","",F2) A3 =IF(B3="","",F3) A4 =IF(B4="","",F4) <tbody> </tbody>

<tbody>
</tbody>

Thanks in advance.

 

[Marcelo Branco]

Try

Sub Copy()
    Dim lr As Long, lr2 As Long, lr3 As Long, r As Long
    
    lr = Sheets("LIST").Cells(Rows.Count, "B").End(xlUp).Row
    lr2 = Sheets("ABOVE 50000 17-18").Cells(Rows.Count, "B").End(xlUp).Row
    lr3 = Sheets("BELOW 50000 17-18").Cells(Rows.Count, "B").End(xlUp).Row
    
    With Sheets("LIST")
        For r = 2 To lr
            If .Range("E" & r).Value = "17-18" And .Range("D" & r).Value > 50000 Then
                .Range("B" & r).Resize(, 4).Copy Destination:=Sheets("ABOVE 50000 17-18").Range("B" & lr2 + 1)
                lr2 = Sheets("ABOVE 50000 17-18").Cells(Rows.Count, "B").End(xlUp).Row
            End If
            If .Range("E" & r).Value = "17-18" And .Range("D" & r).Value < 50000 Then
                .Range("B" & r).Resize(, 4).Copy Destination:=Sheets("BELOW 50000 17-18").Range("B" & lr3 + 1)
                lr3 = Sheets("BELOW 50000 17-18").Cells(Rows.Count, "B").End(xlUp).Row
            End If
        Next r
    End With
End Sub

Hope this helps

M.

 

[manojrf]

Thanks a lot Marcelo. This is what I wanted. Thank you once again.

Regards, Manuel

 

[Marcelo Branco]

You are welcome. Thanks for the feedback.

M.

 

[manojrf]

Hi there,

In continuation to my previous queries, I need one more help

I have a macro that is not working properly.

When I run this, it copies 100 rows and 10 columns, which are blank and non blank, and paste it at the destination Sheet LIST and TOTAL LIST. The Sheet LIST gets cleared before the macro is run next time. When the macro is run again, the data is pasted on to the sheet TOTAL LIST after skipping 100 rows ( not on the first available blank cell in column B). If it is run again, it goes on like this.

Can anyone please help me out.

Thanks in advance.

Sub Copy()

Workbooks("AGL SUBVENTION TOTAL LIST").Activate
Worksheets("LIST").Cells.ClearContents
Workbooks("Gold loan new - SBI - MS Excel").Activate
Worksheets("SUBVN LIST").Select
Worksheets("SUBVN LIST").Range("A2", Range("A" & Rows.Count).End(xlUp).Offset(, 10)).Copy
Workbooks("AGL SUBVENTION TOTAL LIST").Activate
Worksheets("LIST").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
Worksheets("TOTAL LIST").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False

End Sub

 

[Marcelo Branco]

This is a different question. I think you should create a new Thread.

M.

 

[manojrf]

OK