Copy entire row based on condition-i have the code-help plz

[lundbhaiz]

Sub CondCopy()


    ThisWorkbook.Activate
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MySheet"


    Sheets("JCR").Select
    Rows(1).Copy
    
    Sheets("MySheet").Activate
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Font.Bold = True
    
    Application.CutCopyMode = False
        
    Sheets("JCR").Select
    RowCount = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    For i = 1 To RowCount
    
        Range("A" & i).Select
        Check_value = ActiveCell
        If Check_value <> 0 Then
            ActiveCell.EntireRow.Copy
            Sheets("MySheet").Select
            RowCount = Cells(Cells.Rows.Count, "A").End(xlUp).Row
            Range("A" & RowCount + 1).Select
            ActiveSheet.Paste
            Sheets("MySheet").Select
        End If
    Next
End Sub

hi. this is my code. i want to copy entire row to sheet called "MySheet" from sheet "JCR". the copy entire row is base on a condition that if the cell value in column A is not equal to zero then copy entire row and paste it in "MySheet" from row 2. I make this code and run this code and it goes into infinite loop. plz some help me because i cannot see and understand what and where is it going wrong.

 

[lundbhaiz]

Your request is a little vague. How would the 3 sheets together work? Do I copy from three sheets to MySheet, is that it?

yes there are 3 sheets including "JCR" and your assumption is correct. i want do this in 3 sheets one after other and copy entire rows base on same condition to MySheet. Only if it possible i can try or else i will create 3 new sheets and do the same macro for 3 times. this is only option i have. also the data i have in these 3 sheets is very large. like 50k rows in each going up to 200k rows. it take very long time to run the macro so i add the code of calculation setting to manual and to automatic too but it still take very long. but that is okay as long as it work.

 

[lundbhaiz]

same workbook dear. no different workbook or files.

 

[JMonty]

No worries. We'll create a very nifty macro for this. What are the names of the two other sheets?

 

[lundbhaiz]

fantastic !! thanks you so much for this help respected sir. the names for other 2 sheets are - "CWIP" and "OWIP"

 

[lundbhaiz]

oh bad there is one problem. Sheet JCR hsa columns till column T and sheets CWIP and sheet OWIP have columns till column W but the same order. can it work ? or plz dont work on it because you helped me lot and if you cant do it than it is very fine. i will find some way to do it and its okay if i need to run macro 3 time.

 

[lundbhaiz]

can it be like we can create one macro for jcr which is already done and one other macro for cwip and owip combined ? this just my idea and i think it is better option to me.

 

[JMonty]

You have three options, given the info above. We can create two macros. One for JCR, one for the other two. We can create three. OR you can try out this one instead. Just a minor edit and a little speed boost given.

Sub CondCopy()Dim wbk As Workbook
Dim wjcr As Worksheet
Dim wcwip As Worksheet
Dim wowip As Worksheet
Dim lrow As Range
Dim i As Long
Dim j As Long


Set wbk = Application.ThisWorkbook
Set wjcr = wbk.Worksheets("JCR")
Set wcwip = wbk.Worksheets("CWIP")
Set wowip = wbk.Worksheets("OWIP")


On Error GoTo errHandle:
wbk.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MySheet"
Dim wmys As Worksheet
Set wmys = wbk.Worksheets("Mysheet")
j = wjcr.Cells(Rows.Count, 1).End(xlUp).Row


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


For i = 1 To j
    If wjcr.Range("A" & i).Value <> 0 Then
        Set lrow = wmys.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        wjcr.Range("A" & i).EntireRow.Copy
        lrow.PasteSpecial
    End If
	If wcwip.Range("A" & i).Value <> 0 Then
        Set lrow = wmys.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        wcwip.Range("A" & i).EntireRow.Copy
        lrow.PasteSpecial
    End If
	If wowip.Range("A" & i).Value <> 0 Then
        Set lrow = wmys.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        wowip.Range("A" & i).EntireRow.Copy
        lrow.PasteSpecial
    End If
Next i
	
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


Exit Sub


errHandle:
    Select Case Err.Number
        Case 9
            MsgBox "One of your reference sheets is missing!", vbOKOnly, _
                "Source does not exist!"
        Case 1004
            MsgBox "That sheet already exists!", vbOKOnly, _
                "Check your sheets!"
        Case Else
            Resume Next
    End Select


    
End Sub

Let me know if this gives out the correct output. Since it's a copy-paste, it ignores differences in columns with content. I tried it using a 200,000 x 50 grid full of 10-digit strings and it completes the task in about 30s, but this might be because of my computer specs.

Report back immediately and let us know if this helped you out. This will help others with the same problem.

 

[JMonty]

Aha, wait. I just saw a problem with the code above. It doesn't take into consideration the row numbers for each sheet. Let me have a go at it again.

 

[JMonty]

Okay, here it goes. Not the best of codes but it sure will get the job done. Try it out now.

Sub CondCopy()Dim wbk As Workbook
Dim wjcr As Worksheet
Dim wcwip As Worksheet
Dim wowip As Worksheet
Dim lrow As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m as Long
Dim n as Long


Set wbk = Application.ThisWorkbook
Set wjcr = wbk.Worksheets("JCR")
Set wcwip = wbk.Worksheets("CWIP")
Set wowip = wbk.Worksheets("OWIP")


On Error GoTo errHandle:
wbk.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MySheet"
Dim wmys As Worksheet
Set wmys = wbk.Worksheets("Mysheet")
j = wjcr.Cells(Rows.Count, 1).End(xlUp).Row
l = wcwip.Cells(Rows.Count, 1).End(xlUp).Row
n = wowip.Cells(Rows.Count, 1).End(xlUp).Row


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


For i = 1 To j
    If wjcr.Range("A" & i).Value <> 0 Then
        Set lrow = wmys.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        wjcr.Range("A" & i).EntireRow.Copy
        lrow.PasteSpecial
    End If
Next i


For k = 1 to l
	If wcwip.Range("A" & k).Value <> 0 Then
        Set lrow = wmys.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        wcwip.Range("A" & k).EntireRow.Copy
        lrow.PasteSpecial
    End If
Next k


For m = 1 to n
	If wowip.Range("A" & m).Value <> 0 Then
        Set lrow = wmys.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        wowip.Range("A" & m).EntireRow.Copy
        lrow.PasteSpecial
    End If
Next m
	
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


Exit Sub


errHandle:
    Select Case Err.Number
        Case 9
            MsgBox "One of your reference sheets is missing!", vbOKOnly, _
                "Source does not exist!"
        Case 1004
            MsgBox "That sheet already exists!", vbOKOnly, _
                "Check your sheets!"
        Case Else
            Resume Next
    End Select


    
End Sub

Hit us back ASAP.

 

[lundbhaiz]

hah jmonty. there is the problem so i said we do one for jcr and one for cwip and owip combined the order of columns in jcr and cwip or owip does not match and also the number of columns. so it pointless to try this above macro but i can see that you have taken hard efforts to create this macro above an d i realy realy praise that work of you. thanks you so much jmonty. very nice of you kind helps and let me know what this macro do so i know if to implement it in my file because of the problem i said before.