vba按多个条件排序，并将值复制到另一个工作表

Question

大家好，我还有另一个棘手的问题，对你来说可能不是很难，但这对我来说很重要。所以我有一张包含我所有数据的表格，我想按前3个条件排序（拒绝，其他，和年）。能够选择几个月也很好。一旦数据被过滤，我就将其复制并在另一张纸上排序，这样我就可以做一些其他功能并生成一个表格，显示供应商被拒绝的次数。可能有一种更简单的方法可以做到这一点，但目前这是我打耳光的方式。如果您有任何其他建议我想听听他们.Code在年份排序失败。我一直从其他表中获取所有数据

 ''Generates defect list
Sub Make_Defect_List_Yearly()
    Const REJECTED_COL = 8  'Column H (DISPOSITIO)
    Const DATE_COL = 13
    Dim shAD As Worksheet, shVP As Worksheet
    Dim adRng As Range, vpRng As Range, headers() As Variant
    Dim rng As Range, cel As Range, fCell As Range, lCell As Range
    Dim flg As Byte, LastRow As Long, flag As Boolean, i

    Set shAD = Worksheets("AllData")
    Set shVP = Worksheets("VendorProblems")
    lr = shAD.Cells(Rows.Count, 1).End(xlUp).Row
    Sheets("VendorProblems").UsedRange.ClearContents

'Copy VendorProblems to shVP --------------------------
  Application.ScreenUpdating = False
    shAD.AutoFilterMode = False

    With shAD.UsedRange
        Set adRng = FilterWS(.Columns(DATE_COL), "2017")
        If Not adRng Is Nothing Then
            If .Cells.CountLarge > 2 Then
                Set vpRng = shVP.Cells(shVP.UsedRange.Rows.Count + 1, 1)
                .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).Copy vpRng
            End If
        End If
    End With

    With shAD.UsedRange
        Set adRng = FilterWS(.Columns(REJECTED_COL), "Reject")
        If Not adRng Is Nothing Then
            If .Cells.CountLarge > 2 Then
                Set vpRng = shVP.Cells(shVP.UsedRange.Rows.Count + 1, 1)
                .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).Copy vpRng
            End If
        End If
    End With

    With shAD.UsedRange
        Set adRng = FilterWS(.Columns(REJECTED_COL), "Other")
        If Not adRng Is Nothing Then
            If .Cells.CountLarge > 2 Then
                Set vpRng = shVP.Cells(shVP.UsedRange.Rows.Count + 1, 1)
                .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).Copy vpRng
            End If
        End If
    End With



    shAD.AutoFilterMode = False
'shVP.UsedRange.RemoveDuplicates Columns:=1, Header:=xlNo
'Sort shVP ----------------------------------------------------
    Set vpRng = shVP.UsedRange.Columns(11)
    With shVP.Sort
        .SortFields.Clear
        .SetRange shVP.UsedRange
        .SortFields.Add Key:=vpRng, SortOn:=xlSortOnValues, Order:=xlAscending
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
'Remove blanks from shVP --------------------------------------
    With shVP.UsedRange
        shVP.AutoFilterMode = False
        If Len(shVP.Cells(1)) = 0 Then shVP.Cells(1) = "Header": flg = 1
        Set vpRng = FilterWS(shVP.UsedRange.Columns(11), "=")
        If Not vpRng Is Nothing Then
            Set vpRng = shVP.UsedRange.Columns(2).SpecialCells(xlCellTypeVisible)
            If .Cells.Count > 1 Then .SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End If
        If flg = 1 Then shVP.Cells(1).EntireRow.Delete
        shVP.AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
'Copys qty recieved to amnt rejected if amt rejected is blank
    With shVP
        lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        For Each cel In .Range("G2:G" & lr)             'loop through each cell in Column
            If (cel.Value) = "" Then                    'check Command Name
                Set fCell = cel.Offset(0, -3)           'set first cell to be copied in fCell
                Set lCell = cel.Offset(0, 0)
                lCell = fCell
            End If
        Next cel
    End With
'Sorts data alphabetically by vendor
Application.ScreenUpdating = True
    shVP.Activate
    Cells.Select
    Range("A:P").Activate 'old line a118
    With Selection
        .HorizontalAlignment = xlGeneral
        .WrapText = False
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    shVP.Range("A1").Select

    ' Array of header labels
    headers() = Array("Warehouse", "Inspection Type", "ItemID", "QtyReceived", "UOM", "Sample::Sample", "DefectFound", _
                      "Disposition", "PurchOrder", "DISTRIBUTOR", "Manufacturer", "Remarks", "Date", "Cost", "RejectCat", "Date")
    ' Row to insert
    shVP.Activate
    Range("A1").EntireRow.Insert
        With shVP
            For i = LBound(headers()) To UBound(headers())
                .Cells(1, 1 + i).Value = headers(i)
            Next i
    .Rows(1).Font.Bold = True
        End With
End Sub