Excel 如果优先级（从高到低）条件与其他工作表匹配，则复制整行数据

如果优先级标准匹配（P1=最高、P2、P3、P4和P5=最低），则需要帮助复制整行。还有第（A）列任务，其中包含相同任务的重复行。 应遵循的条件如下：-

假设优先级为P1或P2或P3或P4或P5，则只应复制该优先级（P1）的满行作为最高级别（其他级别（P2、P3、P4、P5将不被考虑为其优先级低于P1）。

同样，如果优先级为P2且P1不存在，而其他P3或P4或P5为其优先级，则只会将P2行复制并粘贴到另一张图纸上

以相同的方式，如果存在优先级P3，并且还存在其他P4和P5，则将考虑P3并粘贴完整行。 源数据

结果输出

找到下面我正在使用的代码

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\611892636\OneDrive - BT Plc\Desktop\Nestle JML\Mansi Work\Test\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

'复制优先级的整行基础的代码

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

多谢各位

---

Amit Singh

请修复代码格式每个dim应在单独的一行中，for应在新行中开始。结尾处也需要新行。