VBA .сортировка букв перед цифрами / датами

Поэтому я использую .метод сортировки в VBA для сортировки диапазона дат. В эти даты вплетены случайные буквы, которые означают определенные вещи.

Мне нужен способ сортировать эти письма до даты, и я еще не нашел способ сделать это с помощью .Метод сортировки.

Есть предложения?

БЫВШИЙ)

1/2/16
4/6/16
2/5/16
B
3/25/16
FV
8/10/16

— Должен выглядеть так—

B
FV
1/2/16
2/5/16
3/25/16
4/6/16
8/10/16

— Благодаря —

—текущий код—

Dim x As Workbook
Set x = Workbooks("I G T  Ship Balance sheet Template.xlsx")

lrSort = x.Sheets("Template").Range("A500").End(xlUp).Row

x.Sheets("Template").Range("A2:CJ" & lrSort).Sort Key1:=x.Sheets("Template").Range("G2"), Order1:=xlAscending

3 ответа

  1. Предположим, что ваши данные начинаются с A2. Ваши результаты будут помещены от B2

    Попробуйте С ниже кода

    Sub test()
        lastrow = Range("A" & Rows.Count).End(xlUp).Row
        Dim Data() As String
        Dim incre As Long
        Dim Datanumeric() As String
        ReDim Data(lastrow - 1)
        ReDim Datanumeric(lastrow - 1)
        For i = 2 To lastrow
            If IsNumeric(Replace(Cells(i, 1), "/", "")) = True Then
                Datanumeric(i - 1) = Cells(i, 1)
            Else
                Data(i - 1) = Cells(i, 1)
            End If
        Next i
        Call sort(Data())
        Call sort(Datanumeric())
        incre = Range("B" & Rows.Count).End(xlUp).Row + 1
        For i = 1 To lastrow - 1
            If Data(i) <> "" Then
                Cells(incre, 2) = Data(i)
                incre = incre + 1
            End If
        Next i
        For i = 1 To lastrow - 1
            If Datanumeric(i) <> "" Then
                Cells(incre, 2) = Datanumeric(i)
                incre = incre + 1
            End If
        Next i
    End Sub
    
    Sub sort(list() As String)
        Dim First As Integer, Last As Long
        Dim i As Long, j As Long
        Dim temp As String
        First = LBound(list)
        Last = UBound(list)
        For i = First To Last - 1
            For j = i + 1 To Last
                If list(i) >= list(j) Then
                    temp = list(j)
                    list(j) = list(i)
                    list(i) = temp
                End If
            Next j
        Next i
    End Sub
    

    Доказательство работы

    Введите описание изображения здесь

  2. ОТРЕДАКТИРОВАНО НА ОСНОВЕ НОВОЙ ИНФОРМАЦИИ:

    Приведенный ниже метод использует встроенную функцию пользовательского сортировщика Excel для сортировки на основе ваших требований. Он по-прежнему использует большую часть тех же вспомогательных кодов, что и ранее, но на этот раз он использует Excel для выполнения сортировки, а не прямого применения из массива. Как и в предыдущем коде, это не должен быть список фиксированной длины, но вам придется построить в вашей собственной логике, чтобы проверить размер списка сортировки. Если вам нужна помощь в этом или в чем-то еще, пожалуйста, задавайте конкретные вопросы, и мы постараемся предложить помощь.

    Sub TestTheMethod()
        ' Run the SortCustom Method supplying the range in question.
        ' NOTE: Do NOT include the header row.
        ' First arg is the range to sort
        ' Second arg is the key based on which you want to sort (note, the column only matters)
    
        SortCustom Range("A2:C23"), Range("B1")
    End Sub
    
    
    Sub SortCustom(rInput As Range, rSortField As Range)
        ' First arg is the range to sort WITHOUT headers
        ' Second arg is the sort field (only the column matters)
    
    
        Dim nWidth As Long
        Dim nHeight As Long
        Dim vOutput() As Variant
        Dim ws As Worksheet
        Dim rng As Range
    
        nWidth = rInput.Columns.Count
        nHeight = rInput.Rows.Count
    
        ReDim vOutput(1 To nHeight, 1 To 1)
    
        Set rng = Intersect(rInput, rSortField.EntireColumn)
        vOutput = rng
    
        BubbleSortArrayCustom vOutput, 1
    
        Set ws = rInput.Parent
    
        ws.Sort.SortFields.Clear
        ws.Sort.SortFields.Add Key:=rng, _
            CustomOrder:=Join(WorksheetFunction.Transpose(vOutput), ",")
    
        With ws.Sort
            .SetRange rInput
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    
    End Sub
    
    Private Sub BubbleSortArrayCustom(vArray() As Variant, nCompIdx As Integer)
        Dim vPlaceHolder As Variant
        Dim nFirst As Long
        Dim nSecond As Long
        Dim i As Long
    
        For nFirst = LBound(vArray) To UBound(vArray)
            For nSecond = nFirst + 1 To UBound(vArray)
                If CompareTwoValues(vArray(nFirst, nCompIdx), vArray(nSecond, nCompIdx)) Then
                    For i = LBound(vArray, 2) To UBound(vArray, 2)
                        vPlaceHolder = vArray(nFirst, i)
                        vArray(nFirst, i) = vArray(nSecond, i)
                        vArray(nSecond, i) = vPlaceHolder
                    Next i
                End If
            Next nSecond
        Next nFirst
    End Sub
    
    Private Function CompareTwoValues(v1 As Variant, v2 As Variant) As Boolean
        Dim bOutput As Boolean
        Dim sType1 As String
        Dim sType2 As String
    
        sType1 = TypeName(v1)
        sType2 = TypeName(v2)
    
        If sType1 = "String" And sType2 = "String" Then
            bOutput = (v1 > v2)
        ElseIf sType1 = "String" And sType2 <> "String" Then
            bOutput = False
        ElseIf sType2 = "String" And sType1 <> "String" Then
            bOutput = True
        Else
            bOutput = (v1 > v2)
        End If
    
        CompareTwoValues = bOutput
    End Function
    

    СТАРЫЙ ПОСТ:
    Взгляните на прилагаемый код. Я разбил его на вспомогательные функции, чтобы, надеюсь, позволить вам понять его легче и в конечном итоге изменить его в соответствии с вашими потребностями.

    Код принимает диапазон для сортировки и ключ для сортировки. Затем он использует как массив, пользовательский метод сравнения и пузырьковую сортировку, чтобы отсортировать массив, а затем заменить исходную информацию.

    Попробуйте сделать копию своей работы и убедитесь, что она соответствует вашим потребностям. Дайте нам знать,если вам нужна дополнительная помощь.

    Sub TestTheMethod()
        ' Run the SortCustom Method supplying the range in question.
        ' NOTE: Do NOT include the header row.
        ' First arg is the range to sort
        ' Second arg is the key based on which you want to sort (note, the column only matters)
    
        SortCustom Range("A2:C23"), Range("B1")
    End Sub
    
    
    Sub SortCustom(rInput As Range, rSortField As Range)
        ' First arg is the range to sort WITHOUT headers
        ' Second arg is the sort field (only the column matters)
    
    
        Dim nWidth As Long
        Dim nHeight As Long
        Dim vOutput() As Variant
    
        nWidth = rInput.Columns.Count
        nHeight = rInput.Rows.Count
    
        ReDim vOutput(1 To nHeight, 1 To nWidth)
    
        vOutput = rInput
    
        BubbleSortArrayCustom vOutput, (rSortField.Column - rInput.Range("A1").Column + 1)
    
    
        rInput = vOutput
    End Sub
    
    Private Sub BubbleSortArrayCustom(vArray() As Variant, nCompIdx As Integer)
        Dim vPlaceHolder As Variant
        Dim nFirst As Long
        Dim nSecond As Long
        Dim i As Long
    
        For nFirst = LBound(vArray) To UBound(vArray)
            For nSecond = nFirst + 1 To UBound(vArray)
                If CompareTwoValues(vArray(nFirst, nCompIdx), vArray(nSecond, nCompIdx)) Then
                    For i = LBound(vArray, 2) To UBound(vArray, 2)
                        vPlaceHolder = vArray(nFirst, i)
                        vArray(nFirst, i) = vArray(nSecond, i)
                        vArray(nSecond, i) = vPlaceHolder
                    Next i
                End If
            Next nSecond
        Next nFirst
    End Sub
    
    Private Function CompareTwoValues(v1 As Variant, v2 As Variant) As Boolean
        Dim bOutput As Boolean
        Dim sType1 As String
        Dim sType2 As String
    
        sType1 = TypeName(v1)
        sType2 = TypeName(v2)
    
        If sType1 = "String" And sType2 = "String" Then
            bOutput = (v1 > v2)
        ElseIf sType1 = "String" And sType2 <> "String" Then
            bOutput = False
        ElseIf sType2 = "String" And sType1 <> "String" Then
            bOutput = True
        Else
            bOutput = (v1 > v2)
        End If
    
        CompareTwoValues = bOutput
    End Function
    
  3. Я предполагаю, что, когда вы сортируете его сейчас, цифры появляются в начале и Буквы в конце? Если это всегда так (и ваши буквы никогда не будут начинаться с цифр), не могли бы вы сделать следующее:

    1) сортировать все в порядке, так что теперь ваши письма появляются в начале.

    2) затем отсортировать только буквы в порядке возрастания, а затем сортировки только цифры в порядке возрастания.

    Вы можете определить диапазон букв после шага 1, двигаясь от верхней части отсортированного списка, пока не дойдете до номера.

    Достигло бы это чего вы хотите?