PDA

View Full Version : Solved: cut and paste records based on multiple criteria



Beatrix
05-07-2013, 09:44 AM
Hi All ,

I have exam results list in a worksheet and some records need to be removed from the list based on some criteria below:

If the same student has the same subject then check the exam type. If it is AS level then cut and paste the record into tab "AS level_same subject"

If student fails in the A level (which means exam grade is U) then cut and paste the record into tab "A level_fails"

I attached sample spreadsheet. Could anyone help me on this please:(??

Cheers
Yeliz

mancubus
05-08-2013, 07:54 AM
hi.

try this...


Sub rmv_rows_based_on_cll_value_n_multi_crit_dupes()
Dim ws As Worksheet
Dim r As Range
Dim i As Long, LastRow As Long, LastCol As Long
Dim subj As String

Application.DisplayAlerts = False

'clear existing data, if any...
Worksheets("AS level_same subject").Cells.Clear
Worksheets("A level_fails").Cells.Clear

Set ws = Worksheets("master")
'remove rows based on values in 2 cols, C and D
With ws
Set r = .Range("A1").CurrentRegion
r.Parent.AutoFilterMode = False
r.AutoFilter Field:=3, Criteria1:="A Level"
r.AutoFilter Field:=4, Criteria1:="U"
With .AutoFilter.Range
.Copy Destination:=Worksheets("A level_fails").Range("A1")
.Offset(1, 0).Resize(.Rows.Count - 1).Rows.Delete
End With
r.Parent.AutoFilterMode = False
End With

With ws
'remove duplicate rows based on values in 2 cols, A, B and criteria in C
'a helper column, E, is used
.Rows("1").Copy Destination:=Worksheets("AS level_same subject").Range("A1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'helper column to determine duplicates
For i = 2 To LastRow
subj = Replace(WorksheetFunction.Trim(.Cells(i, "B")), " ", "")
subj = Mid(subj, InStr(1, subj, "-") + 1)
.Cells(i, "E") = .Cells(i, "A") & subj
Next i
'remove duplicate rows from backward
For i = LastRow To 1 Step -1
If Application.CountIf(Range("E2:E" & i), Range("E" & i).Text) > 1 And .Cells(i, "C") = "AS Level" Then
Range("E" & i).EntireRow.Copy _
Destination:=Worksheets("AS level_same subject").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Range("E" & i).EntireRow.Delete
End If
Next i
'delete helper column
.Columns("E:E").EntireColumn.Delete
End With

'delete helper columns
Worksheets("AS level_same subject").Columns("E:E").EntireColumn.Delete
Worksheets("A level_fails").Columns("E:E").EntireColumn.Delete

'autofit columns
Worksheets("AS level_same subject").Columns.AutoFit
Worksheets("A level_fails").Columns.AutoFit

Application.DisplayAlerts = True
End Sub

Beatrix
05-10-2013, 05:41 AM
Thanks very mancubus!! It works perfect:thumb

Cheers
Yeliz





hi.

try this...


Sub rmv_rows_based_on_cll_value_n_multi_crit_dupes()
Dim ws As Worksheet
Dim r As Range
Dim i As Long, LastRow As Long, LastCol As Long
Dim subj As String

Application.DisplayAlerts = False

'clear existing data, if any...
Worksheets("AS level_same subject").Cells.Clear
Worksheets("A level_fails").Cells.Clear

Set ws = Worksheets("master")
'remove rows based on values in 2 cols, C and D
With ws
Set r = .Range("A1").CurrentRegion
r.Parent.AutoFilterMode = False
r.AutoFilter Field:=3, Criteria1:="A Level"
r.AutoFilter Field:=4, Criteria1:="U"
With .AutoFilter.Range
.Copy Destination:=Worksheets("A level_fails").Range("A1")
.Offset(1, 0).Resize(.Rows.Count - 1).Rows.Delete
End With
r.Parent.AutoFilterMode = False
End With

With ws
'remove duplicate rows based on values in 2 cols, A, B and criteria in C
'a helper column, E, is used
.Rows("1").Copy Destination:=Worksheets("AS level_same subject").Range("A1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'helper column to determine duplicates
For i = 2 To LastRow
subj = Replace(WorksheetFunction.Trim(.Cells(i, "B")), " ", "")
subj = Mid(subj, InStr(1, subj, "-") + 1)
.Cells(i, "E") = .Cells(i, "A") & subj
Next i
'remove duplicate rows from backward
For i = LastRow To 1 Step -1
If Application.CountIf(Range("E2:E" & i), Range("E" & i).Text) > 1 And .Cells(i, "C") = "AS Level" Then
Range("E" & i).EntireRow.Copy _
Destination:=Worksheets("AS level_same subject").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Range("E" & i).EntireRow.Delete
End If
Next i
'delete helper column
.Columns("E:E").EntireColumn.Delete
End With

'delete helper columns
Worksheets("AS level_same subject").Columns("E:E").EntireColumn.Delete
Worksheets("A level_fails").Columns("E:E").EntireColumn.Delete

'autofit columns
Worksheets("AS level_same subject").Columns.AutoFit
Worksheets("A level_fails").Columns.AutoFit

Application.DisplayAlerts = True
End Sub

mancubus
05-10-2013, 05:54 AM
you are most welcome.
im glad it helped :)