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

Rabiyudeen

New Member
Joined
Oct 13, 2016
Messages
18
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.

Code:
[/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
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Forum statistics

Threads
1,223,246
Messages
6,170,988
Members
452,373
Latest member
TimReeks

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top