VBA如何根据变量然后优先级查找特定编号

Question

我正在尝试构建一个Excel vba代码，该代码查看来自三列的数据，获取每个变量的最低6个值（共有四个），并获取相邻列并将其粘贴到另一张纸上。

>

这是输入：

这就是我想要的输出：
！

这实际上是输出：
Actual Output

我从我看到的另一篇文章中窃取了很多这段代码，但它似乎是非常随机的。 我还是不太确定代码在做什么，这使我感到很难。

任何建议都会有很大帮助。

更新：使用Ibo对示例数据的修复，效果很好，但是对我的实际数据却出错了。我之所以通过宏而不是手动执行此操作，是因为它是一个更大的宏的一部分，该宏被组合在一起以预测各种原材料的生产消耗以及需要分阶段进行的工作。

这是发生了什么：

Actual Input Data

Error 1004 Message and highlighted code

Output after failure

看起来已经接近了，但是还没有完成实际的排序。

Sub TopPriorityPerPod()

    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rngData As Range
    Dim rngFound As Range
    Dim rngUnqGroups As Range
    Dim GroupCell As Range
    Dim lCalc As XlCalculation
    Dim aResults() As Variant
    Dim aOriginal As Variant
    Dim lNumTopEntries As Long
    Dim i As Long, j As Long, k As Long

    'Change to grab the top X number of entries per category'
    lNumTopEntries = 6

    Set wsData = ActiveWorkbook.Sheets("copy")    'This is where your data is'
    Set wsDest = ActiveWorkbook.Sheets("Sheet6")    'This is where you want to output it'

    Set rngData = wsData.Range("A2", wsData.Cells(Rows.Count, "C").End(xlUp))
    aOriginal = rngData.Value   'Store original values so you can set them back later'

    'Turn off calculation, events, and screenupdating'
    'This allows code to run faster and prevents "screen flickering"'
    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    'If there are any problems with the code, make sure the calculation, events, and screenupdating get turned back on'
    'On Error GoTo CleanExit

    With rngData
        '.Sort .Resize(, 1).Offset(, 1), xlAscending, .Resize(, 1).Offset(, 2), , xlDescending, Header:=xlYes
        .Sort .Resize(, 1).Offset(, 1), xlDescending, Header:=xlYes
    End With

    With rngData.Resize(, 1).Offset(, 1)
        .AdvancedFilter xlFilterInPlace, , , True
        Set rngUnqGroups = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        .Parent.ShowAllData 'Remove the filter

        ReDim aResults(1 To rngUnqGroups.Cells.Count * lNumTopEntries, 1 To 4)
        i = 0

        For Each GroupCell In rngUnqGroups
            Set rngFound = .Find(GroupCell.Value, .Cells(.Cells.Count))
            k = 0
            If Not rngFound Is Nothing Then
                For j = i + 1 To i + lNumTopEntries
                    If rngFound.Offset(j - i - 1).Value = GroupCell.Value Then
                        k = k + 1
                        aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
                        aResults(j, 2) = rngFound.Offset(j - i - 1).Value
                        aResults(j, 3) = rngFound.Offset(j - i - 1, 1).Value
                        aResults(j, 4) = rngFound.Offset(j - i - 1, 2).Value
                    End If
                Next j
                i = i + k
            End If
        Next GroupCell
    End With

    'Output results'
    wsDest.Range("A2").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults

    CleanExit:
    'Turn calculation, events, and screenupdating back on'
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    If Err.Number <> 0 Then
        'There was an error, show the error'
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If

    'Put data back the way it was
    rngData.Value = aOriginal

End Sub

Answer 1

因此，我为您准备了一些东西，这些东西应该可以帮助您实现大部分目标。

您需要做一些事情才能使该文件正常工作（学习机会！）：

（1）调整与文件相关的范围 （2）将输出打印到工作表上。到目前为止，输出已打印到即时调试窗口。

此代码将执行的操作是将每个字母值分类到以字母命名的集合中。

从那里，我们将集合转换为数组。然后，我们在数组上使用“小”工作表函数，并循环遍历6个最低值。

很高兴为您解决任何其他问题！

Public Function CollectionToArray(myCol As Collection) As Variant
'Thanks to user Vityata for this converter function (https://stackoverflow.com/users/5448626/vityata).

    Dim result  As Variant
    Dim cnt     As Long

    ReDim result(myCol.Count - 1)
    For cnt = 0 To myCol.Count - 1
        result(cnt) = myCol(cnt + 1)
    Next cnt
    CollectionToArray = result

End Function

Sub ArraySort()

Dim Cell As Range

Dim KeyMultiple As String

Dim collA As New Collection
Dim collB As New Collection
Dim collC As New Collection
Dim collD As New Collection


Dim Rng_Col As Range
Set Rng_Col = Sheets("Sheet1").Range("A2:A22")

Dim GroupByArr As Variant
GroupByArr = Array("A", "B", "C")


Counter = 0
For i = 1 To 22
        If Cells(i, 1).Value = "A" Then
            Counter = Counter + 1
            KeyMultiple = Letter & "-" & Counter
            collA.Add Item:=Cells(i, 2), Key:=KeyMultiple
        ElseIf Cells(i, 1).Value = "B" Then
            Counter = Counter + 1
            KeyMultiple = Letter & "-" & Counter
            collB.Add Item:=Cells(i, 2), Key:=KeyMultiple
        ElseIf Cells(i, 1).Value = "C" Then
            Counter = Counter + 1
            KeyMultiple = Letter & "-" & Counter
            collC.Add Item:=Cells(i, 2), Key:=KeyMultiple
        ElseIf Cells(i, 1).Value = "D" Then
            Counter = Counter + 1
            KeyMultiple = Letter & "-" & Counter
            collD.Add Item:=Cells(i, 2), Key:=KeyMultiple
        End If
Next i

For i = 1 To 6
    Debug.Print WorksheetFunction.Small(CollectionToArray(collA), i)
    Debug.Print WorksheetFunction.Small(CollectionToArray(collB), i)
    Debug.Print WorksheetFunction.Small(CollectionToArray(collC), i)
    Debug.Print WorksheetFunction.Small(CollectionToArray(collD), i)
Next i



Set collA = New Collection
Set collB = New Collection
Set collC = New Collection
Set collD = New Collection

End Sub

Answer 2

您可以使用不同的方法。在这种方法中，我将数据复制到另一个名为Result的工作表中，然后插入表格，对列进行排序，然后收集行数大于6的范围，然后立即删除整行，快速：

Sub Main()
    Dim i As Long
    Dim rng As Range
    Dim tbl As ListObject
    Dim WS As Worksheet
    Dim WS2 As Worksheet

    Set WS = Worksheets("Sheet1") 'this is where you have the data
    Set WS2 = Worksheets.Add
    WS2.Name = "Result"

    WS.Range("A1").CurrentRegion.Copy
    WS2.Paste

    'sort priority column first
    WS2.ListObjects.Add(xlSrcRange, Range(WS2.UsedRange.Address), , xlYes).Name = "Table1"
    Set tbl = WS2.ListObjects("Table1")

    tbl.Sort.SortFields.Add _
        Key:=Range("Table1[[#All],[Priority]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With tbl.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'sort station column
    tbl.Sort.SortFields.Clear
    tbl.Sort.SortFields.Add _
        Key:=Range("Table1[[#All],[Station]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With tbl.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'remove any row exceeding 6th occurrence
    Dim cnt As Integer


    For i = 1 To tbl.ListRows.Count - 1
        If tbl.ListColumns("Station").DataBodyRange(i, 1).Value = tbl.ListColumns("Station").DataBodyRange(i + 1, 1).Value Then
            cnt = cnt + 1
            If cnt >= 6 Then
                If rng Is Nothing Then
                    Set rng = tbl.ListColumns("Station").DataBodyRange(i + 1, 1)
                Else
                    Set rng = Application.Union(rng, tbl.ListColumns("Station").DataBodyRange(i + 1, 1))
                End If
            End If
        Else
            cnt = 0 'reset the counter
        End If
    Next i

    'remove rows
    If Not rng Is Nothing Then
        tbl.Unlist
        rng.EntireRow.Delete
    End If

End Sub

Answer 3

这是一个利用Array，Dictionary和SortedList对象的解决方案，它的运行速度非常快：

Option Explicit

Sub main()

    Dim wsData As Worksheet: Set wsData = ActiveWorkbook.Sheets("copy")    'This is where your data is'
    Dim wsDest As Worksheet: Set wsDest = ActiveWorkbook.Sheets("Sheet6")    'This is where you want to output

    Dim stations As Variant, station As Variant
    Dim iStation As Long
    Dim stationsList As Object: Set stationsList = CreateObject("Scripting.Dictionary") ' use dictionary to collect unique station values

    With wsData
        stations = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3).Value
        For iStation = 1 To UBound(stations, 1)
            stationsList(stations(iStation, 1)) = stationsList(stations(iStation, 1)) & stations(iStation, 2) & "|" & stations(iStation, 3) & " " ' update current station priorities list and orders
        Next
    End With


    Dim prioritiesAndOrders As Variant, priorityAndOrder As Variant, priority As Variant, order As Variant
    Dim iPriority As Long, nPriorities As Long
    For Each station In stationsList.Keys ' loop through unique stations
        prioritiesAndOrders = Split(Trim(stationsList(station)), " ") ' get current station priorities and corresponding orders list

        With CreateObject("System.Collections.SortedList") ' cerate and reference a sortedList object (it stores keys in ascending order)
            For Each priorityAndOrder In prioritiesAndOrders ' loop through current station priorities and corresponding orders list
                priority = Split(priorityAndOrder, "|")(0) ' get current priority
                order = Split(priorityAndOrder, "|")(1) 'get current priority corresponding order
                .Add priority, order ' store current priority as "key" of SortedList object and its corresponding order as its value
            Next

            nPriorities = WorksheetFunction.Min(.Count - 1, 5) ' define the current station number of priorities to manage
            ReDim results(1 To nPriorities + 1, 1 To 3) As Variant ' size results array accordingly
            For iPriority = 0 To nPriorities ' loop through current station sorted priorities (and corresponding orders) and fill results array with current station in column 1, its priorities in column 2 and priority corresponding order in column 3
                results(iPriority + 1, 1) = station
                results(iPriority + 1, 2) = .GetKey(iPriority)
                results(iPriority + 1, 3) = .GetValueList()(iPriority)
            Next
        End With
        wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Offset(1).Resize(nPriorities + 1, 3).Value = results ' write current station sorted priorities
    Next
End Sub