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 <<<
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
Last edited by a moderator:
