VBA to find the exception and paste the matched records to the new sheet

[Rabiyudeen]

HI All,

I have the exception list in the column B of Sheet 1, I need to check whether any of the exceptions mentioned in column B matching with the column C for the particular name in Sheet 2. If yes, I need to cut and paste the particular records to the new sheet.

One more condition is if the same name has different data other than the exception then we need to neglect it.

Here is the sample data

Below is the sample data for reference
Sheet 1:
[TABLE="class: cms_table_grid, width: 500"]
<tbody>[TR]
[TD]S.NO.[/TD]
[TD]Exception List[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]wide[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]run[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]catch[/TD]
[/TR]
</tbody>[/TABLE]


Sheet 2:

[TABLE="class: cms_table_grid, width: 500"]
<tbody>[TR]
[TD]Team[/TD]
[TD]Name[/TD]
[TD]Score[/TD]
[/TR]
[TR]
[TD]Blue[/TD]
[TD]Antony[/TD]
[TD]Wide-5[/TD]
[/TR]
[TR]
[TD]Blue[/TD]
[TD]Antony[/TD]
[TD]run-25[/TD]
[/TR]
[TR]
[TD]Yellow[/TD]
[TD]Reno[/TD]
[TD]catch-2[/TD]
[/TR]
[TR]
[TD]Red[/TD]
[TD]Prateek[/TD]
[TD]run-15[/TD]
[/TR]
[TR]
[TD]Red[/TD]
[TD]Prateek[/TD]
[TD]wide-5[/TD]
[/TR]
[TR]
[TD]Red[/TD]
[TD]Prateek[/TD]
[TD]catch-2
[/TD]
[/TR]
[TR]
[TD]Red[/TD]
[TD]Prateek[/TD]
[TD]Wicket-1[/TD]
[/TR]
[TR]
[TD]Green[/TD]
[TD]Brian[/TD]
[TD]Catch -1[/TD]
[/TR]
[TR]
[TD]Green[/TD]
[TD]Brian[/TD]
[TD]Run -50[/TD]
[/TR]
[TR]
[TD]Green[/TD]
[TD]Brian[/TD]
[TD]wide -2[/TD]
[/TR]
</tbody>[/TABLE]



In the above sample data, I need to cut Antony, Reno and Brian data and paste it in the new sheet as it has Score column details falls in the exception list.

Prateek data is not required as it has Wicket details which does not fall in the exception list.

I tried the following code, but its take very long time to process. Request if anyone can offer any guidance it would be greatly appreciated. Thanks.

[/COLOR]Sheets("Sheet1").Select
If Not IsEmpty(Range("B2")) Then
    If Not IsEmpty(Range("B3")) Then
    Range("B2").Select
    Exceptn = Range(Selection, Selection.End(xlDown)).Rows.Count
    Else
        Exceptn = 1
    End If
Else
    MsgBox ("Processing Report Requires Exceptions for cleanup")
    Exit Sub
End If


For i = 2 To 2 + Exceptn - 1
        Sheets("Sheet1").Select
        Except = Range("B" & i).Text
        Set ws = Sheets.Add(After:=Worksheets("UnwrittenvariableReport"))
        ws.name = Except
        Sheets("Sheet2").Range("A1:ZZ20000").Copy Destination:=Sheets(Except).Range("A1:ZZ20000")
            
           Equal = "<>" & Except & "*"
            Sheets(Except).Select
            LastRow = Range("A65536").End(xlUp).Row
           Range("A2:K" & LastRow).Select
           Selection.AutoFilter
           Selection.AutoFilter Field:=3, Criteria1:=Equal
          Range("A2", Cells(Rows.Count, "A").End(xlUp)).Rows.Delete


            'Clear the AutoFilter
            Selection.AutoFilter Field:=1
            'Take the AutoFilter off
            Selection.AutoFilter


Next


Sheets("Unwritten variable").Select


FinalExcept = Range("B" & 6).Text
Sheets(FinalExcept).Select




For i = 3 To 3 + Exceptn - 2
    
    Sheets("Sheet1").Select


    Except = Range("B" & i).Text
    Sheets(Except).Select
    LastRow2 = Range("A65536").End(xlUp).Row
    LastRow2 = LastRow2 + 1
    Temp2 = "A" & LastRow2
           
    Sheets(FinalExcept).Select
    LastRow1 = Range("A65536").End(xlUp).Row
    LastRow1 = LastRow1 + 1
    Temp1 = "A" & LastRow1
    Sheets(Except).Range("A7:F" & LastRow2).Copy Destination:=Sheets(FinalExcept).Range("A" & LastRow1)
        
Next




Set ws = Sheets.Add(After:=Worksheets("Sheet2"))
        ws.name = "Exception_Sig"
        Sheets(FinalExcept).Range("A1:ZZ20000").Copy Destination:=Sheets("Exception_Sig").Range("A1:ZZ20000")
          


For i = 2 To 2 + Exceptn - 1
    Sheets("Sheet1").Select
    Except = Range("C" & i).Text
    Sheets(Except).Select
    Worksheets(Except).Delete


Next




Set ws = Sheets.Add(After:=Worksheets("Sheet2"))
        ws.name = "InvException_Sig"
Sheets("Sheet2").Range("A1:ZZ20000").Copy Destination:=Sheets("InvException_Sig").Range("A1:ZZ20000")
For i = 2 To 2 + Exceptn - 1
        Sheets("Sheet1").Select
        Except = Range("B" & i).Text
        Equal = "=" & Except & "*"
         Sheets("InvException_Sig").Select
            LastRow = Range("A65536").End(xlUp).Row
           Range("A6:K" & LastRow).Select
           Selection.AutoFilter
           Selection.AutoFilter Field:=3, Criteria1:=Equal
          Range("A7", Cells(Rows.Count, "A").End(xlUp)).Rows.Delete


            'Clear the AutoFilter
            Selection.AutoFilter Field:=1
            'Take the AutoFilter off
            Selection.AutoFilter
  Next
  
    'Compare
    
  Set ws = Sheets.Add(After:=Worksheets("Sheet2"))
    ws.name = "CleanUpList"
  
  Set ws1 = Worksheets("Exception_Sig")
  Set ws2 = Worksheets("InvException_Sig")
  Set ws3 = Worksheets("CleanUpList")
  K = 2




      newSheetPos = ws3.Cells(ws3.Rows.Count, 1).End(xlUp).Row


For i = 7 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
        isMatch = False
        For j = 7 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
            If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value Then
                
                Exit For
                Else
                ws1.Cells(i, 1).EntireRow.Copy ws3.Cells(newSheetPos, 1)
                isMatch = True
                newSheetPos = newSheetPos + 1
                End If
             
ws3.Select
Set rRange = Range("C1", Range("C" & Rows.Count).End(xlUp))
lCount = rRange.Rows.Count
    
For lCount = lCount To 1 Step -1
With rRange.Cells(lCount, 1)
If WorksheetFunction.CountIf(rRange, .Value) > 1 Then
.EntireRow.Delete
End If
End With
Next lCount


        Next j
        If isMatch = False Then newSheetPos = newSheetPos + 1
    Next i

 

[Rabiyudeen]

I would be really grateful if anyone could help me out on this scripting. Thanks