Sorting Groups of Rows Excel VBA Macro

问题

I am having trouble figuring out how to create a sorting algorithm in VBA that sorts and swaps groups of rows (several rows at a time). I wrote a successful sorting algorithm using an array below:

Function SortArray(ByRef arrToSort As Variant)
Dim aLoop As Long, aLoop2 As Long
Dim str1 As String
Dim str2 As String
For aLoop = 1 To UBound(arrToSort)
   For aLoop2 = aLoop To UBound(arrToSort)
        If UCase(arrToSort(aLoop2)) < UCase(arrToSort(aLoop)) Then
            str1 = arrToSort(aLoop)
            str2 = arrToSort(aLoop2)
            arrToSort(aLoop) = str2
            arrToSort(aLoop2) = str1
        End If
    Next aLoop2
Next aLoop
SortArray = arrToSort

(where each element is an element of an array) but now I want to sort by swapping rows or groups of rows. I'll explain what I mean below.

I have a worksheet with headers at the top and rows of data underneath:

I want to write a command that works like the algorithm above. HOWEVER, instead of swapping elements of an array I want to swap entire groups of rows. Header3 ((Can be any string) determines the grouping. All groups on the worksheet are sorted individually and a grouping.

In order to do swap grouped rows, I wrote the following sub RowSwapper() that takes in two strings containing the rows to swap. (e.g. in the form rws1 = "3:5").

Public Sub RowSwapper(ByVal rws1 As String, ByVal rws2 As String)
'ACCOMODATE VARIABLE ROW LENGTHS!!!!
    ActiveSheet.Rows(rws1).Cut
    ActiveSheet.Rows(rws2).Insert Shift:=xlDown
    ActiveSheet.Rows(rws2).Cut
    ActiveSheet.Rows(rws1).Insert Shift:=xlDown
    MsgBox "RowSwapper: row" & rws1 & "swapped with row " & rws2
End Sub

Any ideas? My strategy, including code, is listed below:

MY STRATEGY: I have the arrays prLst and srtdPrLst. prLst is an array of sorting priorities. The position of the priority in prLst is the column (header) to which it refers. srtdPrLst, is an array containing those priorities sorted in numerically ascending order (e.g. 1,2,3....)

I loop through srtdPrLst while calling function FindPosition to find position of each priority. I loop backwards in order to sort in the proper order.

To sort groups of rows, I then use the same technique as the SortArray code above. However, I need to gather the rows in which a group exists. To do this, I have two Do While loops nested under the for loops, one for each group (since I am comparing two groups at). These rows are stored in variables grpCnt1 (for first compared group) and grpCnt1 (for second compared group).

Since individual groups are already sorted, I only need to compare the first row of each group. I compare the strings grp1Val with grp2Val with a simple If statement. If the strings are not in alphabetical order, I call rowSwapper (listed above) to swap them.

The code described is below:

lstRowVal = Int(ActiveSheet.Range("AB" & totCount).Value) 'The index in the array prLst is the column at which a priority is assigned to 'therefore, pos = column number 'Sorts backwards in order to get priorities in appriopriate order 'MsgBox "marker = " & marker

For prior2 = Int(UBound(srtdPrLst)) To 1 Step -1
    MsgBox "prior2 = " & prior2
    If Int(srtdPrLst(prior2)) > 0 Then
        pos = FindPosition(Int(srtdPrLst(prior2)), prLst)

        'Algorithm to sort groups
        For lLoop = 2 To lstRowVal '2 b/c Starts at row below headers


            'Find first group to compare
            grp1Val = ActiveSheet.Range(Mid(alphabet, pos, 1) & lLoop).Value
            hdToGrp1Val = ActiveSheet.Range(Mid(alphabet, hdrMrkr, 1) & lLoop).Value

            Do
                'nextGrp1Val = ActiveSheet.Range(Mid(alphabet, pos, 1) & (lLoop + grpCnt1)).Value
                nxtHdToGrp1 = ActiveSheet.Range(Mid(alphabet, hdrMrkr, 1) & (lLoop + grpCnt1)).Value
                grpCnt1 = grpCnt1 + 1
            Loop While nxtHdToGrp1 = hdToGrp1Val


           For lLoop2 = lLoop To lstRowVal 

                'Find second group to compare
                grp2Val = ActiveSheet.Range(Mid(alphabet, pos, 1) & lLoop2).Value
                hdToGrp2Val = ActiveSheet.Range(Mid(alphabet, hdrMrkr, 1) & lLoop2).Value

                Do
                    nxtHdToGrp2 = ActiveSheet.Range(Mid(alphabet, hdrMrkr, 1) & (lLoop2 + grpCnt2)).Value
                    grpCnt2 = grpCnt2 + 1
                Loop While nxtHdToGrp2 = hdToGrp2Val

                If UCase(grp2Val) < UCase(grp1Val) Then
                    RowSwapper lLoop & ":" & (lLoop + grpCnt1), lLoop2 & ":" & (lLoop2 + grpCnt2) 
                End If

                grp2Val = ""
                lLoop2 = lLoop2 + grpCnt2
                grpCnt2 = 0

            Next lLoop2


            grp1Val = ""
            lLoop = lLoop + grpCnt1
            grpCnt1 = 0

        Next lLoop
    End If
Next prior2

回答1:

I agree that the question is still a little unclear. Have you tried doing a sort from the Data>Sort... You can sort using multiple keys and use custom lists.

Additionally since you said you wanted some pointers on the VBA...:) I don't think stuff like

Dim letString, idLabel, curCell As String

is doing what you are expecting. What is actually happening here is

Dim letString as Variant, idLabel as Variant, curCell As String

because you don't specify after each variable. I assume what you want here is actually:

Dim letString as String, idLabel as String, curCell As String

Second, if you are concerned about efficiency like in your last comment then I would avoid using the .select method of manipulating ranges. You can do everything in excel without it. It is just an extra burden. So instead of doing something like Selction.Resize(1).Select you could log the locations of the beginning and end of your rand in an integer variable then change it into a range object once all your criteria are met. You can feed this range object into your sorting function.

Just something to chew on.

来源：https://stackoverflow.com/questions/6671273/sorting-groups-of-rows-excel-vba-macro

标签

sorting

excel-vba

row

grouping

vba