copy range under conditions

[whitoulias]

Good day to all

With this code i search in Sheets("data") for -1, copy that entire row to Sheets("Result"), delete the row and sort the sheets("data").

Sub Transfer()
    Dim c As Long
    Dim wsD As Worksheet: Set wsD = Worksheets("Data")    'Data Worksheet.
    Dim wsR As Worksheet: Set wsR = Worksheets("Results")    'Results Worksheet
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=COUNTBLANK(RC[1]:RC[17])-1"
    Range("A2").Copy Range("A2", Cells(Rows.Count, "B").End(xlUp).Offset(0, -1))
    For c = 2 To 3002    'Loop through 3000 records.
        With wsD.Range("A" & c)
            If .Value = -1 Then    'Test for -1.
                wsD.Range("B" & c & ":S" & c & "").Copy
                wsR.Activate
                wsR.Range("A" & wsR.Range("A" & Rows.Count).End(xlUp).Row + 1).Select
                Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
                                                                              :=False, Transpose:=False
                
                        End If
              End With
    Next c
     For c = 2 To 3002    'Loop through 3000 records.
        With wsD.Range("A" & c)
            If .Value = -1 Then    'Test for -1.
                wsD.Range("B" & c & ":S" & c & "").ClearContents
               
               
                         End If
              End With
    Next c
              wsD.Activate
              Range("A1:S3002").Select
    Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

End Sub

Can anyone tell me if i can add an extra search?

I would like after searching for -1 to perform the same actions for "9". Is that possible?
Since this macro is activated by a command button, can i have two macros in the same button (i'm thinking dublicating the code.

Thank you

 

[ravi4ever]

This can be done on the same command button, no need for duplicationg the code.. also you have used two loops and the 2nd loop can also be eliminated it we clear the contents as soon we are copying it to the result sheet..

Use this simplified code for both the conditions.. untested but should work..

 Sub Transfer()

    Dim c As Long
    Dim wsD As Worksheet: Set wsD = Worksheets("Data")    'Data Worksheet.
    Dim wsR As Worksheet: Set wsR = Worksheets("Results")    'Results Worksheet
    
    Range("A2").FormulaR1C1 = "=COUNTBLANK(RC[1]:RC[17])-1"
    Range("A2").Copy Range("A2", Cells(Rows.Count, "B").End(xlUp).Offset(0, -1))
    
    For c = 2 To Cells(Rows.Count, "A").End(xlUp).Row    'Loop through all records.
        With wsD.Range("A" & c)
            If .Value = -1 Or .Value = 9 Then    'Test for -1 and 9.
                wsD.Range("B" & c & ":S" & c & "").Copy
                wsR.Range("A" & wsR.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                wsD.Range("B" & c & ":S" & c & "").ClearContents
            End If
        End With
    Next c
    
    wsD.Activate
    Range("A1:S" & Cells(Rows.Count, "A").End(xlUp).Row).Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    Range("A1").Activate

End Sub

 

[whitoulias]

Dear ravi
thx for the reply
I missed one critical point and i'm really sorry for that
When "9" is found the row must be paste in another sheet (see the code below)
Also thank you for noticing and eleminating second loop

Sub Transfer2()
 Dim c As Long
    Dim wsD As Worksheet: Set wsD = Worksheets("data")    'Data Worksheet.
    Dim wsR As Worksheet: Set wsR = Worksheets("-1 results")    'Results Worksheet
    Dim wsP As Worksheet: Set wsR = Worksheets("9 results")    'Results Positive
    wsD.Activate
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[14]=R3C27,9,COUNTBLANK(RC[1]:RC[17])-1)"
    Range("A2").Copy Range("A2", Cells(Rows.Count, "B").End(xlUp).Offset(0, -1))
    For c = 2 To 3002    'Loop through 3000 records.
        With wsD.Range("A" & c)
            If .Value = 9 Then    'Test for 9.
                wsD.Range("B" & c & ":S" & c & "").Copy
                Sheets("9 results").Activate
                Sheets("9 results").Range("A" & wsR.Range("A" & Rows.Count).End(xlUp).Row + 1).Select
                Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
                                                                              :=False, Transpose:=False
                
                        End If
              End With
    Next c
     For c = 2 To 3002    'Loop through 3000 records.
        With wsD.Range("A" & c)
            If .Value = 9 Then    'Test for 9.
                wsD.Range("B" & c & ":S" & c & "").ClearContents
               
               
                         End If
              End With
    Next c
              wsD.Activate
              Range("A1:S3002").Select
    Selection.Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub

What i actually did is dublicate the first macro and at the end of it i input

 Call macro2

 

[ravi4ever]

Again no need of duplicating the code, now you have 4 loops in 2 macros where that can be done in just one loop.. here's an updated version which will keep the results on separate sheets by using a single loop on a single command button..

Sub Transfer()

    Dim c As Long
    Dim wsD As Worksheet: Set wsD = Worksheets("data")    'Data Worksheet.
    Dim wsR As Worksheet: Set wsR = Worksheets("-1 results")    'Results Worksheet
    Dim wsP As Worksheet: Set wsP = Worksheets("9 results")    'Results Positive

    Range("A2:A" & Cells(Rows.Count, "B").End(xlUp).Offset(0, -1)).FormulaR1C1 = "=COUNTBLANK(RC[1]:RC[17])-1"
    
    For c = 2 To Cells(Rows.Count, "A").End(xlUp).Row    'Loop through all records.
        With wsD.Range("A" & c)
            If .Value = -1 Then    'Test for -1
                wsD.Range("B" & c & ":S" & c & "").Copy
                wsR.Range("A" & wsR.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                wsD.Range("B" & c & ":S" & c & "").ClearContents
            ElseIf .Value = 9 Then    'Test for 9
                wsD.Range("B" & c & ":S" & c & "").Copy
                wsP.Range("A" & wsP.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                wsD.Range("B" & c & ":S" & c & "").ClearContents
            End If
        End With
    Next c
    
    wsD.Activate
    Range("A1:S" & Cells(Rows.Count, "A").End(xlUp).Row).Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    Range("A1").Activate

End Sub

 

[whitoulias]

ravi thanks again
i'm impressed by the integration

I get a 'Run time error 1004
Method Range of object Global failed
in:

Range("A2:A" & Cells(Rows.Count, "B").End(xlUp).Offset(0, -1)).FormulaR1C1 = "=COUNTBLANK(RC[1]:RC[17])-1"

</pre>

 

[ravi4ever]

just replace it with..

Range("A2:A" & Cells(Rows.Count, "B").End(xlUp).Row).FormulaR1C1 = "=COUNTBLANK(RC[1]:RC[17])-1"

now the whole procedure should work fine..

 

[whitoulias]

Ravi thanks a lot
You saved me a lot of time and bits
Thanks again

 

[ravi4ever]

Glad it worked for you, , good luck..

 

[whitoulias]

Again no need of duplicating the code, now you have 4 loops in 2 macros where that can be done in just one loop.. here's an updated version which will keep the results on separate sheets by using a single loop on a single command button..

Sub Transfer()

    Dim c As Long
    Dim wsD As Worksheet: Set wsD = Worksheets("data")    'Data Worksheet.
    Dim wsR As Worksheet: Set wsR = Worksheets("-1 results")    'Results Worksheet
    Dim wsP As Worksheet: Set wsP = Worksheets("9 results")    'Results Positive

    Range("A2:A" & Cells(Rows.Count, "B").End(xlUp).Offset(0, -1)).FormulaR1C1 = "=COUNTBLANK(RC[1]:RC[17])-1"
    
    For c = 2 To Cells(Rows.Count, "A").End(xlUp).Row    'Loop through all records.
        With wsD.Range("A" & c)
            If .Value = -1 Then    'Test for -1
                wsD.Range("B" & c & ":S" & c & "").Copy
                wsR.Range("A" & wsR.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                wsD.Range("B" & c & ":S" & c & "").ClearContents
            ElseIf .Value = 9 Then    'Test for 9
                wsD.Range("B" & c & ":S" & c & "").Copy
                wsP.Range("A" & wsP.Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                wsD.Range("B" & c & ":S" & c & "").ClearContents
            End If
        End With
    Next c
    
    wsD.Activate
    Range("A1:S" & Cells(Rows.Count, "A").End(xlUp).Row).Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    Range("A1").Activate

End Sub

Here is a new question about it:
In (elseif. value) i would like to use a different range than { With wsD.Range("A" & c) }
Is it possible?