Copying full row data if priority level criteria matches to another sheet

[AmitSingh]

Hi All, Need help to copy the full row if Priority Level criteria matches (P1=Highest, P2, P3, P4 and P5=Lowest). Also column (A) Task having duplicate rows of same Task.

Till now i have written the code to copy the P1 data from sheet Data into another sheet name Data1 of workbook named SourceData using if condition. Facing issue while copying the data of P2,P3,P4 and P5 into another sheet Data1.

Below is the condition which i am following to paste the full data on the basis of priority level.
1. Suppose if Priority level is P1 or P2 or P3 or P4 or P5 then it should only copy full row of that priority level (P1) as it is highest level (other level (P2,P3,P4,P5 will not be consider as their priority level is lower than P1).
2. In the same, if Priority level is P2 and P1 is not present and other P3 or P4 or P5 is their then only P2 row will be copied and pasted to another sheet as P2 level is greater than P3,P4 and P5.
3. In the same way, if priority level P3 is present, and other P4 and P5 is also present, then P3 will be consider and full row will pasted and P4 and P5 level will not be copied.
4. In the same way, if priority level P4 is present, and other P5 is also present, then P4 will be consider and full row will pasted and P5 level will not be copied.
5. And lastly if P5 level is present then it will copy the P5 row into another sheet of data1

Find below code which i am using.
Source File name :- SourceData.xlsx
Macro File name:- TimeCalc.xlsb

Any suggestion or advise will be help full to me.

Thank you!!
Amit Singh

Why do You open a duplicate thread again and again and again?

Do not make more duplicates with this thread!

>>> as well as - - - - use code - tags <<<

Option Explicit

Sub Timecalculation()

Dim wb As Workbook
Dim wks As Worksheet
Dim objList As ListObject
Dim LastRow, Lsheet2 As Long
Dim sht As Worksheet
Dim myfile As Variant
Dim i, j As Integer

'code for opening excel file to process
myfile = Application.GetOpenFilename(Filefilter:="Excel Files,*.xl*;*.xm*")
If myfile <> False Then
   Workbooks.Open Filename:=myfile
End If

'code for convereting table into Range
For Each wks In ActiveWorkbook.Worksheets
    For Each objList In wks.ListObjects
        objList.Unlist
     Next objList
Next wks
Range("H1").Select

'Adding new sheet and copy header from Data sheet
Application.ScreenUpdating = False
Worksheets("Data").Activate
Rows("1:1").Select
Selection.Copy
Sheets.Add(After:=Sheets("Data")).Name = "Data1"
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False

'code for copying full row basis of Priority level
Worksheets("Data").Activate
Range("A1").Select
LastRow = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
    If Worksheets("Data").Cells(i, 8).Value = "P1" Then
        Worksheets("Data").Rows(i).Copy
        Worksheets("Data1").Activate
        Lsheet2 = Worksheets("Data1").Cells(Rows.Count, 1).End(xlUp).Row
        Worksheets("Data1").Cells(Lsheet2 + 1, 1).Select
        ActiveSheet.Paste
        Worksheets("Data").Activate
    End If
Next i
Application.CutCopyMode = False
Range("A1").Select
Application.DisplayAlerts = False

End Sub

 

[RDAngelo]

A possible solution...?

Sub Timecalculation()
    Dim wb As Workbook
    Dim ws As Worksheet

    Application.ScreenUpdating = False
    
    'open file
    On Error Resume Next
    Set wb = Workbooks.Open(Application.GetOpenFilename(Filefilter:="Excel Files,*.xl*;*.xm*"))
    On Error GoTo 0
    If wb Is Nothing Then Exit Sub
    
    'copy data to new worksheet
    wb.Sheets("Data").Copy After:=wb.Sheets("Data")
    Set ws = ActiveSheet
    ws.Name = "Data1"
    
    'sort data by priorty
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=Range("H1"), Order:=xlAscending
        .SetRange ws.Range("H1").CurrentRegion
        .Header = xlYes
        .Apply
    End With
    
    'remove duplicate tasks
    ws.Cells(1, 1).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    Application.ScreenUpdating = True
End Sub

 

[AmitSingh]

Thank you RDAngelo for providing the solution.
As i can see it will delete the duplicate rows of column A of Task, but i need to extract the data on the basis of Priority level (P1,P2,P3,P4 and P5) as P1 is the highest and P5 is lowest. That is why if you see my code i have used For Loop and If condition for that.
Suppose P1 is found and that row is copied to another sheet, then next condition will check for P2 leaving that Task of column A and start checking from where it find the P1 value. Same goes for P3, P4 and P5 also.
Hope if you have got my point. I am also stuck in that issue only.

Thanks for helping out.

Regards,
Amit Singh

 

[RDAngelo]

The code makes a copy of the data, sorts it from P1 to P5 and then removes any duplicate tasks, leaving the highest priority task in the resulting data... Run the code and check the results.