• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Copying full row data if priority level (highest to lowest) criteria matches in to another sheet

AmitSingh

Member
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.
Condition to be followed are below:-
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.
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.
4. Code present in "Module3".

Please find below code (also attaching files for reference) which i am using for above condition but it is not working as expected. Any help will be great full.

>>> as many times given a note: use code - tags <<<
Code:
Option Explicit

Sub Timecalculation()

Dim wb As Workbook
Dim wks As Worksheet
Dim objList As ListObject
Dim LastRow As Long
Dim sht As Worksheet

Dim rngCell As Range
Dim lngLstRow As Long
Dim strPri() As String
Dim intPriMax As Integer
Dim tWs As Worksheet
Dim i As Long

Set wb = Workbooks.Open("C:\Users\Desktop\SourceData.xlsx")
wb.Sheets("Data").Activate
For Each wks In ActiveWorkbook.Worksheets
    For Each objList In wks.ListObjects
        objList.Unlist
     Next objList
Next wks
Range("H1").Select

'adding column for Mid Value
Set sht = ActiveSheet
Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Value = "Mid Value"
ActiveSheet.Range("H2").Select
Range("H2:H" & Cells(Rows.Count, 1).End(xlUp).Row).Formula = "=Mid(RC[-1],20,2)"
Columns("H:H").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("I1").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
Application.CutCopyMode = False

'code for copying full row basis of Priority level
ReDim strPri(1 To intPriMax)
Worksheets("Data").Activate
Range("A1").Select
strPri(1) = "P1"
strPri(2) = "P2"
strPri(3) = "P3"
strPri(4) = "P4"
strPri(5) = "P5"
With Sheets("Data1")

LastRow = .Range("A" & .Rows.Count).End(xlUp)

For Each rngCell In .Range("A2:A" & LastRow)
    For i = 1 To intPriMax
        If strPri(i) = rngCell.Value Then
           tWs.Rows(tWs.Range("A" & tWs.Rows.Count).End(xlUp).Offset(1, 0).Row).Value = .Rows(rngCell.Row).Value
        End If
    Next i
Next
End With
Application.DisplayAlerts = False

End Sub
 

Attachments

Last edited by a moderator:
Top