Copy rows from one worksheet to another based on criteria

[twildone]

I would like to copy entire rows from a master worksheet to destination worksheets based on the result in column C for the row in the master worksheet. Below is the code and everytime I run it, it copies the rows to the correct destination worksheet but it copies to the next available and open row that does not have any data in it. I would like for it to always copy the rows to the destination worksheet to begin at Row 2 regardless if there is data or not. I would greatly appreciate any suggestions.....thanks


<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
Public Sub CopyRows()
Sheets("Data").Select
' Find the last row of data
FinalRow = Range("A65536").End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column C
ThisValue = Range("C" & x).Value
If ThisValue = "LIR" Then
Range("A" & x & ":AG" & x).Copy
Sheets("LIR").Select
NextRow = Range("A65536").End(xlUp).Row + 1
Range("A" & NextRow).Select
ActiveSheet.Paste
Sheets("Data").Select
ElseIf ThisValue = "KLE" Then
Range("A" & x & ":AG" & x).Copy
Sheets("KLE").Select
NextRow = Range("A65536").End(xlUp).Row + 1
Range("A" & NextRow).Select
ActiveSheet.Paste
Sheets("Data").Select
End If
Next x
<o> </o>
End Sub

 

[Clay Canvas]

Try this and let me know if it works for you. I modified your code slightly and added some additional code to clear out the previous data on the LIR & KLE sheets which you may or may not want depending on whether or not there's a risk of having old data left over and if that's desirable or not in your situation.

Steve

Public Sub CopyRows_clearData()

Sheets("Data").Select

' Find the last row of data
FinalRow = Range("A65536").End(xlUp).Row
NextRow_LIR = 2
NextRow_KLE = 2

    'clear previous contents (keep if you'd like to ensure no old data remains)
    lastrow = Sheets("LIR").Range("A65536").End(xlUp).Row
    If lastrow > 1 Then
        With Sheets("LIR").Range("A2:AG" & lastrow)
            .ClearContents
        End With
    End If
    lastrow = Sheets("KLE").Range("A65536").End(xlUp).Row
    If lastrow > 1 Then
        With Sheets("KLE").Range("A2:AG" & lastrow)
            .ClearContents
        End With
    End If
    
' Loop through each row
For x = 2 To FinalRow

    ' Decide if to copy based on column C
    ThisValue = Range("C" & x).Value
    
        If ThisValue = "LIR" Then
            Range("A" & x & ":AG" & x).Copy
            Sheets("LIR").Select
            Range("A" & NextRow_LIR).Select
            ActiveSheet.Paste
            Sheets("Data").Select
            NextRow_LIR = NextRow_LIR + 1
        Else
            If ThisValue = "KLE" Then
                Range("A" & x & ":AG" & x).Copy
                Sheets("KLE").Select
                Range("A" & NextRow_KLE).Select
                ActiveSheet.Paste
                Sheets("Data").Select
                NextRow_KLE = NextRow_KLE + 1
            End If
        End If 
    
Next x

End Sub

 

[Peter_SSs]

I have assumed that you want to start in row 2 to preserve headings in row 1 but that the headings could just as well be copied each time from the 'Data' sheet.

Test this in a copy of your workbook.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> CopyFromData()<br>    <SPAN style="color:#00007F">Dim</SPAN> mySheets<br>    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    mySheets = Array("LIR", "KLE") <SPAN style="color:#007F00">'<- Add more if you want</SPAN><br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> i = <SPAN style="color:#00007F">LBound</SPAN>(mySheets) <SPAN style="color:#00007F">To</SPAN> <SPAN style="color:#00007F">UBound</SPAN>(mySheets)<br>        <SPAN style="color:#00007F">With</SPAN> Sheets(mySheets(i))<br>            .UsedRange.ClearContents<br>            Sheets("Data").UsedRange.Copy Destination:=.Range("A1")<br>            <SPAN style="color:#00007F">With</SPAN> .UsedRange<br>                .AutoFilter Field:=3, Criteria1:="<>" & mySheets(i)<br>                .Offset(1).EntireRow.Delete<br>                .AutoFilter<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> i<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

By the way, about how many rows is there likely to be in the 'Data' sheet?

Also, when posting code you will get many more potential helpers if you post indented code. That can be done using code tags as Clay Canvas did or using the VBHTML Maker as I did. See my signature block for more details of both methods.

 

[Clay Canvas]

Pretty cool approach Peter. I learned a few new things reading thru your code.

Thanks,

Steve

 

[twildone]

Thanks Steve and Peter for your suggestions.

Steve - I the code with your modifications and I get and error message....."Compile Error: Next without For" and it is referring to the "Next x" at the end of the code just before "End Sub". Is there something missing?

 

[Clay Canvas]

I believe that can happen when an IF statement is not closed with an End If statement. The code works ok on my computer. Maybe check to see if you have any IF statements without the closing End IF statement.

Steve

 

[Peter_SSs]

Did my code produce the results you expected?

 

[twildone]

Steve - Yes you were right.....I was missing an End If Statement at the end of the code.

Peter - I didn't try to use the code you had suggested only because it looked more complicated for me since I am relatively new at this...but I am sure it would have worked.

Thank you so much to both of you for taking the time to respond and provide your suggestions.....it is greatly appreciated.

 

[gssachin]

Hello Peter Sir,

Your code works for me, Thanks a lot
Only one help required, I want to paste data as value only is it possible ???

 

[Peter_SSs]

Only one help required, I want to paste data as value only is it possible ???

Try making this replacement.

<del>Sheets("Data").UsedRange.Copy Destination:=.Range("A1")</del>
Sheets("Data").UsedRange.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues