按部分文本对行组进行排序

Question

我的数据库以HTML格式输出数据，这种方式对我没用。我希望能够在Excel中重新排序它。问题有两个：

1）数据一次输出9行，有3个标题行。在排序时，这9行中的每一行都需要按顺序保存在一起。

2）主要排序键是其中一个数据单元的SECOND HALF。在附图中，H14是我需要排序的位置，包含“3M（WSW）” - 但我不想按“3M”排序，我想按“（WSW）”排序。现在，并非每个数据元素都在括号中的部分，并且并非每个数据元素在括号之前都有任何内容，但括号内的部分是我想要排序的部分。辅助排序键是同一单元格的前半部分，第三级排序键是A5，A14等中的部件号。

我搜索了谷歌和这个网站寻求帮助，我明白我可以添加一些额外的列来排序（或制作一个VBA程序进行排序，但我还没有用VBA编写15年的代码现在，我不觉得它。这个数据库转储有一百个记录，所以我需要一些公式来用来制作这些排序列 - 我不可能每周用数百条记录手工完成。我不知道如何制作按我的主要，次要和第三类排序标准排序的公式，并按原始顺序保留组内的行。

Answer 1

经过几天的尝试，我得出的结论是，如果没有VBA，这项任务根本无法完成。因此，我刷了我的VBA（它并没有我想象的那么难），并编写了以下代码。

总结一下，我必须解析首字母，解析品牌名称，抓取部件号，抓取索引，然后将它们混合成一个可以分类的字符串。然后我拉出索引并使用它将数据元素复制到sheet2并稍微美化它们。

Private Sub CommandButton1_Click()

    Dim iElements       As Long
    Dim vSortKey()      As Variant
    Dim iSortOrder()    As Long

    iElements = 0

    ' How Many Part Numbers Were Added?
    Do Until IsEmpty(Cells(5 + (iElements * 9), 8)) = True
        iElements = iElements + 1
    Loop
    iElements = iElements - 1

    ReDim vSortKey(iElements)
    ReDim iSortOrder(iElements)

'*************************
' Create the Sorting Key.
'*************************
'   Our Primary Sort is the Initials of the Product Development employee, found in the Parenthesis of Cell H5, and every 9 cells after that
'   Our Secondary Sort is the Brand Name, found before the Parenthesis of Cell H5, and every 9 cells after that
'   Our Tertiary Sort is the Part Number, found in Cell A5, and every 9 cells after that
' Finally, place the location of the element at the end, so we can find it again on the source sheet.
' Each Key (and the source location) is placed in a single string, and seperated by a colon.
'   The Split() command can be used to extract each of these elements from the string, effectively making this a 4D array (index 0 to 3)
'   (but a 4D array that's MUCH easier to sort)
    For i = 0 To iElements
        vSortKey(i) = FindName(Cells((5 + (i * 9)), 8)) & ":" & FindBrand(Cells((5 + (i * 9)), 8)) & ":" & Cells((5 + (i * 9)), 1) & ":" & i
    Next i

    QuickSort vSortKey, 0, iElements

    ' For convenience, extract the "location" of the sorted elements into a seperate array: iSortOrder()
    Dim tmp() As String
    For i = 0 To iElements
        tmp = Split(vSortKey(i), ":")
        iSortOrder(i) = CLng(tmp(3))
    Next i

'*****************************************
' Create the Finished Worksheet on Sheet2
'*****************************************
' Finished Sheet must have a repeating header, borders between elements, and other beautification done
' Note that there are 37 rows to a page, and with 7 rows to an element, 5 will fit per page with 3 rows left for the header.
    Dim pagecount As Long
    pagecount = 0

    For i = 0 To iElements

    ' Every five elements is a new page.  Every new page, copy the header and update current page count.
        If (((i + 1) Mod 5) - 1) = 0 Then
            CopyHeader ((pagecount * 37) + 1)
            pagecount = pagecount + 1
        End If

        For m = 1 To 16
            If (((i + 1) Mod 5) - 1) <> 0 Then
                Sheet2.Cells((pagecount * 2) + (i * 7), m).Borders(xlEdgeTop).LineStyle = xlContinuous
                Sheet2.Cells((pagecount * 2) + (i * 7), m).Borders(xlEdgeTop).Weight = xlThin
            End If

            For n = 0 To 7
                Sheet2.Cells((pagecount * 2) + (i * 7) + n, m) = Sheet1.Cells((5 + (iSortOrder(i) * 9) + n), m)

                If ((n = 0) Or (n = 2)) Then
                    Sheet2.Cells((pagecount * 2) + (i * 7) + n, 11).NumberFormat = "$#.#0"
                ElseIf ((n = 1) Or (n = 3)) Then
                    Sheet2.Cells((pagecount * 2) + (i * 7) + n, 11).NumberFormat = "m/d/yyyy"
                End If

            Next n
        Next m

        Sheet2.Cells((pagecount * 2) + (i * 7), 1).RowHeight = 22.5

    Next i

End Sub

Public Sub CopyHeader(iStart As Long)

    For i = 1 To 16
            Sheet2.Cells(iStart, i) = Sheet1.Cells(1, i)
            Sheet2.Cells(iStart, i).Borders(xlEdgeBottom).LineStyle = xlContinuous
            Sheet2.Cells(iStart, i).Borders(xlEdgeBottom).Weight = xlThick
            Sheet2.Cells(iStart, i).Font.Bold = True
    Next i

End Sub

Public Function FindName(vStr As Variant) As Variant

    Dim StartPos As Long
    Dim EndPos As Long
    Dim Length As Long

    FindName = ""

    If Len(vStr) > 0 Then
        StartPos = InStr(vStr, "(") + 1
        EndPos = InStr(vStr, ")")
        Length = EndPos - StartPos

        If Length <> 0 Then
            FindName = Mid(vStr, StartPos, EndPos - StartPos)
        End If
    End If

End Function

Public Function FindBrand(vStr As Variant) As Variant

    Dim Length As Long

    FindBrand = ""

    If Len(vStr) > 0 Then
        Length = InStr(vStr, "(") - 2
        If Length > 0 Then
            FindBrand = Left(vStr, Length)
        Else
            FindBrand = vStr
        End If
    End If

End Function

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)

  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)

     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If

  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi

End Sub