VBA中的自定义排序（可能来自列表）_Vba_Excel_Sorting

VBA中的自定义排序（可能来自列表）

vba excel sorting

VBA中的自定义排序（可能来自列表）,vba,excel,sorting,Vba,Excel,Sorting,要排序的表：我有一张2000英镑的表格。第一列包含以下类型的非唯一ID:[数字1-52][字母][可选下划线][可选数字1-10]。字母将为[a]、[b]、[c]、[sa]、[sb]、[sc] 示例：1c、10sb_3、5a、12c、3sc、21c_1、22c_4、22b_10、14sb、26sb 我要怎么分类我想先按输入字母排序，按照我在上面示例之前命名的顺序。如果是同一类型，我想按第一个数字排序。如果第一个数字相同，两个可选参数都将出现，我想按最后一个数字排序。排序也应该扩展到行表的其余

要排序的表：

我有一张2000英镑的表格。第一列包含以下类型的非唯一ID:[数字1-52][字母][可选下划线][可选数字1-10]。字母将为[a]、[b]、[c]、[sa]、[sb]、[sc]

示例：1c、10sb_3、5a、12c、3sc、21c_1、22c_4、22b_10、14sb、26sb

我要怎么分类

我想先按输入字母排序，按照我在上面示例之前命名的顺序。如果是同一类型，我想按第一个数字排序。如果第一个数字相同，两个可选参数都将出现，我想按最后一个数字排序。排序也应该扩展到行表的其余部分

期望的最终结果

我打算做的可能不是最好的主意

以这个问题的答案为起点：

我可以做一个算法，在旁边创建第二个列表，删除所有重复项，然后手动按我想要的方式排列该列表。这需要一段时间，而且可能效率极低。完成后，我会使用一段与答案类似的代码：

Dim oWorksheet As Worksheet
Set oWorksheet = ActiveWorkbook.Worksheets("Sheet1")
Dim oRangeSort As Range
Dim oRangeKey As Range

' one range that includes all colums do sort
Set oRangeSort = oWorksheet.Range("A1:J2000") ' <<<<I'd set the range right, of course
' start of column with keys to sort
Set oRangeKey = oWorksheet.Range("B1") '<<<What is this for?

' custom sort order
Dim sCustomList(x To y) As String
'There would be a loop here filling the array in order with my manually sorted list

Application.AddCustomList ListArray:=sCustomList
' use this if you want a list on the spreadsheet to sort by
' Application.AddCustomList ListArray:=Range("D1:D3")
' ^^^^ for the record I'm not sure what this accomplishes in my case. Should I remove it? I feel it is just a different way to fill the array, using the range directly instead of filling with a loop. Maybe it suits me more?

oWorksheet.Sort.SortFields.Clear
oRangeSort.Sort Key1:=oRangeKey, Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

' clean up
Application.DeleteCustomList Application.CustomListCount
Set oWorksheet = Nothing

就个人而言，除非您需要将其作为更大代码的一部分来执行，否则我不会使用VBA，而只会在数据表中添加一列，为您提供正确的排序顺序

要提取ID的相关部分（假设它从单元格A1开始），您需要从字符串中拉出字母：

=MID(A1,MIN(FIND({"a","b","c","s"},A1&"abcs")),IF(ISNUMBER(FIND("s",A1)),2,1))

接下来，您需要第一个号码：

=LEFT(A1,MIN(FIND({"a","b","c","s"},A1&"abcs"))-1)

然后，您需要添加第二个数字（如果存在）：

=IF(ISNUMBER(FIND("_",A1)),RIGHT(A1,LEN(A1)-FIND("_",A1))*1,0)

将所有这些都放在一个公式中，并将数字的格式设置为考虑到一位数或两位数，可以得到：

=MID(A1,MIN(FIND({"a","b","c","s"},A1&"abcs")),IF(ISNUMBER(FIND("s",A1)),2,1))&TEXT(LEFT(A1,MIN(FIND({"a","b","c","s"},A1&"abcs"))-1),"00")&TEXT(IF(ISNUMBER(FIND("_",A1)),RIGHT(A1,LEN(A1)-FIND("_",A1))*1,0),"00")

这可能不是实现它的最简单的方法，但会给您一列字符串，您可以将其用作排序顺序

我唯一感到困惑的是，你的问题说字母需要按照你列出的顺序排序，但是你的例子显示c在b之前。如果您需要字母按非字母顺序排列，我们需要调整此公式的第一部分。

如果可能的话，为了使其更简单，我建议的第一件事是保持字段类型、第一个数字、特殊参数、可选数字的长度相同，这将使算法变得非常简单

1c2变为01oc-02 23sa_13保留23sa_13 但如果你没有这种可能性，那就这样：

这将逐个分离新工作表中的所有值，包括重复的值

Option Explicit

Sub SortData()


    Dim MySheet As Worksheet, NewSheet As Worksheet
    Set MySheet = ThisWorkbook.Worksheets("Sheet1")
    Set NewSheet = ThisWorkbook.Worksheets.Add()

    NewSheet.Range("A1").value = "Type"
    NewSheet.Range("B1").value = "First Number"
    NewSheet.Range("C1").value = "Underscore"
    NewSheet.Range("D1").value = "Last Number"

    Dim CurrentRange As Range
    Dim i As Integer

    For i = 2 To 2000 'the rows you are going to consider
        'you may replace this for a while cell is not empty check
        'considering the first row is a header, not a value

        Set CurrentRange = MySheet.Cells(i, 1)  'gets the cell in row i and column 1
        Dim CurrentValue As String
        CurrentValue = CurrentRange.value   'gets the value of the cell

        'if cell is empty, stop loop
        If CurrentValue = "" Then
            Exit For
        End If

        Dim FirstNumberSize As Integer
        Dim TypeSize As Integer
        Dim UnderscoreSize As Integer
        Dim LastNumberSize As Integer

        Dim StartChar As Integer
        StartChar = 1
        Call GetFieldSizes(CurrentValue, FirstNumberSize, TypeSize, UnderscoreSize, LastNumberSize)


        'write the values in a new sheet
        NewSheet.Cells(i, 2).value = Mid(CurrentValue, StartChar, FirstNumberSize) 'write firstnumber in the new sheet
        StartChar = StartChar + FirstNumberSize 'advance to the next field

        NewSheet.Cells(i, 1).value = Mid(CurrentValue, StartChar, TypeSize) 'write type in the new sheet
        StartChar = StartChar + TypeSize

        NewSheet.Cells(i, 3).value = Mid(CurrentValue, StartChar, UnderscoreSize) 'write underscore in the new sheet - nothing if size is zero
        StartChar = StartChar + UnderscoreSize

        NewSheet.Cells(i, 4).value = Mid(CurrentValue, StartChar, LastNumberSize) 'write lastNumber in the new sheet - nothing if size is zero
    Next

End Sub

Sub GetFieldSizes(value As String, ByRef firstNum As Integer, ByRef entryType As Integer, ByRef Underscore As Integer, ByRef lastNum As Integer)

    'walk through each char of the value while it's a number


    Dim Continue As Boolean
    Dim charVal As String
    Dim valLength As Integer
    valLength = Len(value) 'the length of the string


    'find first number size
    firstNum = 0  'start from character zero
    Continue = True 'to check if I can advance to the next char
    Do
        'if the next char is not a number, we found the letters
        If Not IsNumeric(Mid(value, firstNum + 1, 1)) Then
            Continue = False    'I say I cannot advance anymore, the size of our number is found
        Else
            firstNum = firstNum + 1 'advance one char
        End If

    Loop While Continue = True 'repeat while I can continue


    'find first underscore or digit of last number

    For Underscore = firstNum + 1 To valLength 'from the first char after the first number to the end of the string

        charVal = Mid(value, Underscore, 1) 'get the value of the char in the current underscore position

        If charVal = "_" Then   'if the char is an underscore
            lastNum = valLength - Underscore 'the remaining chars are the last number
            Underscore = 1 'the actual size of the underscore is 1
            Exit For 'interrupt the loop
        ElseIf IsNumeric(charVal) Then  'if the char is a number
            lastNum = valLength - Underscore + 1 'the remaining chars, including this one are the last number
            Underscore = 0 'if I find a number instead of the underscore, it doesn't exist, say it's length is zero
            Exit For 'interrupt the loop
        End If
    Next

    'if I advanced to the end of the string, I didn't find any number of underscore
    If Underscore > valLength Then
        lastNum = 0
        Underscore = 0
    End If

    entryType = valLength - firstNum - Underscore - lastNum 'the size of the letters is the remaining size when you remove the other sizes
End Sub

我已经有了一个按字母类型列出的无重复值的列表。字母可能是a-z，坦白说，你是对的，只要它们分开，我不介意。我正在做一个冒泡排序，按我现在想要的顺序得到列表，现在数字把10认为不如1…如果你把我给你的公式放在你的数据旁边的一个列中，然后使用那个新的列排序，这会给你你想要的结果吗？

Option Explicit

Sub SortData()


    Dim MySheet As Worksheet, NewSheet As Worksheet
    Set MySheet = ThisWorkbook.Worksheets("Sheet1")
    Set NewSheet = ThisWorkbook.Worksheets.Add()

    NewSheet.Range("A1").value = "Type"
    NewSheet.Range("B1").value = "First Number"
    NewSheet.Range("C1").value = "Underscore"
    NewSheet.Range("D1").value = "Last Number"

    Dim CurrentRange As Range
    Dim i As Integer

    For i = 2 To 2000 'the rows you are going to consider
        'you may replace this for a while cell is not empty check
        'considering the first row is a header, not a value

        Set CurrentRange = MySheet.Cells(i, 1)  'gets the cell in row i and column 1
        Dim CurrentValue As String
        CurrentValue = CurrentRange.value   'gets the value of the cell

        'if cell is empty, stop loop
        If CurrentValue = "" Then
            Exit For
        End If

        Dim FirstNumberSize As Integer
        Dim TypeSize As Integer
        Dim UnderscoreSize As Integer
        Dim LastNumberSize As Integer

        Dim StartChar As Integer
        StartChar = 1
        Call GetFieldSizes(CurrentValue, FirstNumberSize, TypeSize, UnderscoreSize, LastNumberSize)


        'write the values in a new sheet
        NewSheet.Cells(i, 2).value = Mid(CurrentValue, StartChar, FirstNumberSize) 'write firstnumber in the new sheet
        StartChar = StartChar + FirstNumberSize 'advance to the next field

        NewSheet.Cells(i, 1).value = Mid(CurrentValue, StartChar, TypeSize) 'write type in the new sheet
        StartChar = StartChar + TypeSize

        NewSheet.Cells(i, 3).value = Mid(CurrentValue, StartChar, UnderscoreSize) 'write underscore in the new sheet - nothing if size is zero
        StartChar = StartChar + UnderscoreSize

        NewSheet.Cells(i, 4).value = Mid(CurrentValue, StartChar, LastNumberSize) 'write lastNumber in the new sheet - nothing if size is zero
    Next

End Sub

Sub GetFieldSizes(value As String, ByRef firstNum As Integer, ByRef entryType As Integer, ByRef Underscore As Integer, ByRef lastNum As Integer)

    'walk through each char of the value while it's a number


    Dim Continue As Boolean
    Dim charVal As String
    Dim valLength As Integer
    valLength = Len(value) 'the length of the string


    'find first number size
    firstNum = 0  'start from character zero
    Continue = True 'to check if I can advance to the next char
    Do
        'if the next char is not a number, we found the letters
        If Not IsNumeric(Mid(value, firstNum + 1, 1)) Then
            Continue = False    'I say I cannot advance anymore, the size of our number is found
        Else
            firstNum = firstNum + 1 'advance one char
        End If

    Loop While Continue = True 'repeat while I can continue


    'find first underscore or digit of last number

    For Underscore = firstNum + 1 To valLength 'from the first char after the first number to the end of the string

        charVal = Mid(value, Underscore, 1) 'get the value of the char in the current underscore position

        If charVal = "_" Then   'if the char is an underscore
            lastNum = valLength - Underscore 'the remaining chars are the last number
            Underscore = 1 'the actual size of the underscore is 1
            Exit For 'interrupt the loop
        ElseIf IsNumeric(charVal) Then  'if the char is a number
            lastNum = valLength - Underscore + 1 'the remaining chars, including this one are the last number
            Underscore = 0 'if I find a number instead of the underscore, it doesn't exist, say it's length is zero
            Exit For 'interrupt the loop
        End If
    Next

    'if I advanced to the end of the string, I didn't find any number of underscore
    If Underscore > valLength Then
        lastNum = 0
        Underscore = 0
    End If

    entryType = valLength - firstNum - Underscore - lastNum 'the size of the letters is the remaining size when you remove the other sizes
End Sub