Excel сортировка нескольких столбцов на основе определенной строки

Question

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

Я написал код VBA, чтобы вставить конкретные номера моих офисных материалов в другой лист Excel, который просто объединяет их и вычисляет материал, относящийся к стоимости.Пока все просто.

Теперь я хочу отсортировать мои «офисные номера», которые выглядят как «1.2.30», «1.1.1130» или «1.3.150» в ряд слева направо.Как вы видите по числам, которые они сосут, чтобы сортировать, я должен изменить их, чтобы отсортировать их правильно, вопрос в том, как это сделать.Также в столбцах «Офисные номера» есть другие номера, которые я хочу поменять на «офисные номера» в столбцах.

Пример!

Сортировка:

1.2.30   1.1.1130  1.3.150

1        4         7      
2        5         8
3        6         9

На это:

1.1.1130   1.2.30   1.3.150

4          1        7
5          2        8
6          3        9

Excel будет сортировать это так: 1.2.30, 1.3.150, 1.1.1130

Мне нужно найти способ, как изменить эти числав нормальные числа (что я уже сделал, исключив эти «.») и сохранив их в виде строки после последней точки и добавив столько «0», чтобы я предположил стандартизированные числа с длиной 5 чисел?поэтому все номера моего офиса после последней точки выглядят следующим образом: 1.2.30 = (1.2.) 00030, 1.3.150 = (1.3.) 150 = 00150 и 1.1.1130 = (1.1.) 01130

Код для сортировки, который я пробовал до сих пор:

Sub Table1Sort()

    Range("B39:Q39").Select
    Selection.ClearContents

    Range("B44:Q44").Select
    Selection.ClearContents

    Range("B9:Q28").Select

    ActiveWorkbook.Worksheets("Table1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Table1").Sort.SortFields.Add2 Key:=Range( _
        "B10:Q10"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Table1").Sort
        .SetRange Range("B9:Q28")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With

    Dim rng As Range

    For Each rng In Range("B9:Q9")
        rng = rng
    Next

End Sub

Сохранение чисел в виде строк и добавление нулей, может быть?Или, может быть, моя логика все неправильно?что вы думаете по этому поводу с VBA?

Answer 1

Предлагаемое решение ниже.

Sub Table1Sort()
    Dim i As Long
    Dim rg As Range, cl As Range
    Dim parts As Variant
    Dim fmt As String, id As String

    fmt = String(4, "0")                                        'in this case 4 seems to be the max lenght of number parts, adjust as needed
    Set rg = Range("A1:C5")                                     'your range to get sorted - adjust to the correct address

    For Each cl In rg.Rows(1).Cells                             'Transform numbers into a sort string, unless blank
        If cl <> "" Then
            id = ""
            parts = Split(cl.Text, ".")                             'Split into parts by numbers, pad with leading zeroes and concatenate with a separator
            For i = 0 To UBound(parts)
                id = id & "-" & Format(CInt(parts(i)), fmt)
            Next i
            id = Mid(id, 2)                                         'Remove leading separator
            cl.Value = id                                           'Put into cell
        End If
    Next cl

    ActiveWorkbook.Worksheets("Table1").Sort.SortFields.Clear                       'Do the sorting
    ActiveWorkbook.Worksheets("Table1").Sort.SortFields.Add2 Key:=rg.Rows(1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Table1").Sort
        .SetRange rg
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With

    For Each cl In rg.Rows(1).Cells                           'Transform sort strings back to original
        If cl <> "" Then
            id = ""
            parts = Split(cl.Text, "-")
            For i = 0 To UBound(parts)
                id = id & "." & CInt(parts(i))
            Next i
            id = Mid(id, 2)
            cl.Value = id
        End If
    Next cl

End Sub

Вы также можете рассмотреть возможность передачи целевого диапазона в качестве параметра.

Answer 2

Это мой готовый код с помощью @Dschuli и @Miles Fett.

Теперь он работает без проблем:)

Sub Table1Sort()
    Dim i As Long
    Dim rg As Range, cl As Range
    Dim parts As Variant
    Dim fmt As String, id As String

    fmt = String(5, "0")                                        
    Set rg = Tabelle1.Range("B9:Q28")                          

    For Each cl In rg.Rows(1).Cells                             
        If cl <> "" Then
            id = ""
            parts = Split(cl.Text, ".")                             
            For i = 0 To UBound(parts)
                id = id & "-" & Format(CInt(parts(i)), fmt)
            Next i
            id = Mid(id, 2)                                         
            cl.Value = id                                           
        End If
    Next cl


    Tabelle1.Sort.SortFields.Clear                                                  
    Tabelle1.Sort.SortFields.Add Key:=rg.Rows(1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With Tabelle1.Sort
        .SetRange rg
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With

    Tabelle1.Range("B39:Q39").ClearContents
    Tabelle1.Range("B44:Q44").ClearContents


    For Each cl In rg.Rows(1).Cells                           
        If cl <> "" Then
            id = ""
            parts = Split(cl.Text, "-")
            For i = 0 To UBound(parts)
                id = id & "." & CInt(parts(i))
            Next i
            id = Mid(id, 2)
            cl.Value = id
        End If
    Next cl
End Sub

Answer 3

Вот что я придумал:

Option Explicit


Sub Table1Sort()
    Dim i As Integer
    Dim iRows As Integer
    Dim iLen As Integer
    Dim Arr() As Variant

    ActiveSheet.Range("d3:e5").Select  'I randomly entered the values to be sorted in a column here.

    iRows = Selection.Rows.Count 'Figure out how many items I'm dealing with.
    Arr = Range("d3:e5").Value2  'Write them to an array. I include the column next to the data as a placeholder.

    For i = 1 To iRows  'Strip periods and fill/overwrite 2nd column of array
        Arr(i, 2) = Replace(Arr(i, 1), ".", "")
        If Len(Arr(i, 2)) > iLen Then iLen = Len(Arr(i, 2))
    Next i

    For i = 1 To iRows 'Pad with trailing zeros
        Do While Len(Arr(i, 2)) < iLen
            Arr(i, 2) = Arr(i, 2) & "0"
        Loop
    Next i

    QuickSortArray Arr, , , 2  'Call the sort found here: https://stackoverflow.com/a/5104206/12000364

    For i = 1 To iRows  'Write the results out across columns. I randomly start at column F.
        Cells(1, 5 + i) = Arr(i, 1)
    Next i

End Sub

Как я уже упоминал в комментариях к коду, я использовал сортировку многомерного массива, найденную здесь - https://stackoverflow.com/a/5104206/12000364 и отсортированную по 2-му измерению.