Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Сортировка на основании маркировки наименования - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сортировка на основании маркировки наименования (Макросы/Sub)
Сортировка на основании маркировки наименования
Сергей13 Дата: Суббота, 07.09.2019, 13:25 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 237
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Здравствуйте!
Ребята, есть ли какой способ сортировки текста методом vba в начале которого прописана числовая нумерация (маркировка) в виде разделов и подразделов (данная маркировка присуща дорожным знакам, пример последовательности маркировки частично показан в примере).
К сообщению приложен файл: 2917515.xlsx(10.6 Kb)
 
Ответить
СообщениеЗдравствуйте!
Ребята, есть ли какой способ сортировки текста методом vba в начале которого прописана числовая нумерация (маркировка) в виде разделов и подразделов (данная маркировка присуща дорожным знакам, пример последовательности маркировки частично показан в примере).

Автор - Сергей13
Дата добавления - 07.09.2019 в 13:25
InExSu Дата: Суббота, 07.09.2019, 14:14 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 573
Репутация: 67 ±
Замечаний: 0% ±

Excel 2010
Привет!
Поменял местами ячейки, отсортировал обычной сортировкой - нормально сортирует.


На сохранение второго закона термодинамики: яндекс.кошелёк 410012113235839
 
Ответить
СообщениеПривет!
Поменял местами ячейки, отсортировал обычной сортировкой - нормально сортирует.

Автор - InExSu
Дата добавления - 07.09.2019 в 14:14
Сергей13 Дата: Суббота, 07.09.2019, 14:25 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 237
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
InExSu, пример можно показать что получилось у Вас после сортировки от А до Я?


Сообщение отредактировал Сергей13 - Суббота, 07.09.2019, 14:27
 
Ответить
СообщениеInExSu, пример можно показать что получилось у Вас после сортировки от А до Я?

Автор - Сергей13
Дата добавления - 07.09.2019 в 14:25
InExSu Дата: Суббота, 07.09.2019, 14:38 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 573
Репутация: 67 ±
Замечаний: 0% ±

Excel 2010
Упс. не получилось :-(
Может добавить нули, чтобы сортировалось правильно?


На сохранение второго закона термодинамики: яндекс.кошелёк 410012113235839
 
Ответить
СообщениеУпс. не получилось :-(
Может добавить нули, чтобы сортировалось правильно?

Автор - InExSu
Дата добавления - 07.09.2019 в 14:38
Сергей13 Дата: Суббота, 07.09.2019, 14:54 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 237
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
InExSu, по разному пробовал не получается, данная маркировка это по сути некое подобие подразделов которое формирует как последовательность расположения (и быстрого нахождения при ведении учета) в группах так и нормативное обозначение каждого знака, поэтому добавление нулей создаст путаницу.


Сообщение отредактировал Сергей13 - Суббота, 07.09.2019, 15:36
 
Ответить
СообщениеInExSu, по разному пробовал не получается, данная маркировка это по сути некое подобие подразделов которое формирует как последовательность расположения (и быстрого нахождения при ведении учета) в группах так и нормативное обозначение каждого знака, поэтому добавление нулей создаст путаницу.

Автор - Сергей13
Дата добавления - 07.09.2019 в 14:54
InExSu Дата: Суббота, 07.09.2019, 21:48 | Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 573
Репутация: 67 ±
Замечаний: 0% ±

Excel 2010
Во вложении первая часть - принуждение к естественной сортировке.
Уборку лидирующих нулей напишем позже ...

К сообщению приложен файл: Sort_NAt_InExSu.xlsb(24.1 Kb)


На сохранение второго закона термодинамики: яндекс.кошелёк 410012113235839
 
Ответить
СообщениеВо вложении первая часть - принуждение к естественной сортировке.
Уборку лидирующих нулей напишем позже ...


Автор - InExSu
Дата добавления - 07.09.2019 в 21:48
krosav4ig Дата: Воскресенье, 08.09.2019, 05:32 | Сообщение № 7
Группа: Друзья
Ранг: Старожил
Сообщений: 2164
Репутация: 905 ±
Замечаний: 0% ±

Excel 2007,2010,2013
вариант [vba]
Код
Option Explicit

Sub Sorting()
    Dim arr() As Variant, s, maxLevel%, i, j, v, s0$, dic As Object, arr1 As Variant
    Set dic = CreateObject("scripting.dictionary")
    With ActiveSheet.UsedRange.Columns(1)
        ReDim arr(.Rows.Count - 1)
        For Each s In .Value
            j = 0: s0 = "'"
            
            For Each v In Split(Split(s, "_")(0), ".")
                s0 = s0 & Application.Dec2Hex(Val(v), 4)
                j = j + 1
            Next
            
            If j > maxLevel Then
                maxLevel = j
            Else
                ShiftLeft s0, maxLevel - j
            End If
            
            If Not IsArray(dic(maxLevel)) Then
                dic(maxLevel) = Array(i)
            Else
                arr1 = dic(maxLevel)
                ReDim Preserve arr1(UBound(arr1) + 1)
                arr1(UBound(arr1)) = i
                dic(maxLevel) = arr1
            End If
            
            arr(i) = Array(s0, s)
            i = i + 1
        Next
        
        For j = maxLevel - 1 To 1 Step -1
            If IsArray(dic(j)) Then
                For Each i In dic(j)
                    ShiftLeft arr(i)(0), maxLevel - j
                Next
            End If
        Next
        Quicksort arr, 0, UBound(arr)

        .Value = Application.Index(arr, 0, 2)
    End With
End Sub
Private Sub ShiftLeft(ByRef s, n)
    s = s & Application.Rept("0000", n)
End Sub

Private Sub Quicksort(vArray As Variant, arrLbound As Long, arrUbound As Long)
    'Sorts a one-dimensional VBA array from smallest to largest
    'using a very fast quicksort algorithm variant.
    Dim pivotVal As Variant
    Dim vSwap    As Variant
    Dim tmpLow   As Long
    Dim tmpHi    As Long

    tmpLow = arrLbound
    tmpHi = arrUbound
    pivotVal = vArray((arrLbound + arrUbound) \ 2)(0)

    While (tmpLow <= tmpHi) 'divide
        While (vArray(tmpLow)(0) < pivotVal And tmpLow < arrUbound)
            tmpLow = tmpLow + 1
        Wend
  
        While (pivotVal < vArray(tmpHi)(0) And tmpHi > arrLbound)
            tmpHi = tmpHi - 1
        Wend

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

    If (arrLbound < tmpHi) Then Quicksort vArray, arrLbound, tmpHi 'conquer
    If (tmpLow < arrUbound) Then Quicksort vArray, tmpLow, arrUbound 'conquer
End Sub
[/vba]
К сообщению приложен файл: 2917515.xlsm(18.3 Kb)


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщениевариант [vba]
Код
Option Explicit

Sub Sorting()
    Dim arr() As Variant, s, maxLevel%, i, j, v, s0$, dic As Object, arr1 As Variant
    Set dic = CreateObject("scripting.dictionary")
    With ActiveSheet.UsedRange.Columns(1)
        ReDim arr(.Rows.Count - 1)
        For Each s In .Value
            j = 0: s0 = "'"
            
            For Each v In Split(Split(s, "_")(0), ".")
                s0 = s0 & Application.Dec2Hex(Val(v), 4)
                j = j + 1
            Next
            
            If j > maxLevel Then
                maxLevel = j
            Else
                ShiftLeft s0, maxLevel - j
            End If
            
            If Not IsArray(dic(maxLevel)) Then
                dic(maxLevel) = Array(i)
            Else
                arr1 = dic(maxLevel)
                ReDim Preserve arr1(UBound(arr1) + 1)
                arr1(UBound(arr1)) = i
                dic(maxLevel) = arr1
            End If
            
            arr(i) = Array(s0, s)
            i = i + 1
        Next
        
        For j = maxLevel - 1 To 1 Step -1
            If IsArray(dic(j)) Then
                For Each i In dic(j)
                    ShiftLeft arr(i)(0), maxLevel - j
                Next
            End If
        Next
        Quicksort arr, 0, UBound(arr)

        .Value = Application.Index(arr, 0, 2)
    End With
End Sub
Private Sub ShiftLeft(ByRef s, n)
    s = s & Application.Rept("0000", n)
End Sub

Private Sub Quicksort(vArray As Variant, arrLbound As Long, arrUbound As Long)
    'Sorts a one-dimensional VBA array from smallest to largest
    'using a very fast quicksort algorithm variant.
    Dim pivotVal As Variant
    Dim vSwap    As Variant
    Dim tmpLow   As Long
    Dim tmpHi    As Long

    tmpLow = arrLbound
    tmpHi = arrUbound
    pivotVal = vArray((arrLbound + arrUbound) \ 2)(0)

    While (tmpLow <= tmpHi) 'divide
        While (vArray(tmpLow)(0) < pivotVal And tmpLow < arrUbound)
            tmpLow = tmpLow + 1
        Wend
  
        While (pivotVal < vArray(tmpHi)(0) And tmpHi > arrLbound)
            tmpHi = tmpHi - 1
        Wend

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

    If (arrLbound < tmpHi) Then Quicksort vArray, arrLbound, tmpHi 'conquer
    If (tmpLow < arrUbound) Then Quicksort vArray, tmpLow, arrUbound 'conquer
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 08.09.2019 в 05:32
InExSu Дата: Воскресенье, 08.09.2019, 09:43 | Сообщение № 8
Группа: Проверенные
Ранг: Ветеран
Сообщений: 573
Репутация: 67 ±
Замечаний: 0% ±

Excel 2010
Привет!
05:32

Вот это я понимаю : охота пуще неволи!


На сохранение второго закона термодинамики: яндекс.кошелёк 410012113235839
 
Ответить
СообщениеПривет!
05:32

Вот это я понимаю : охота пуще неволи!

Автор - InExSu
Дата добавления - 08.09.2019 в 09:43
Сергей13 Дата: Четверг, 12.09.2019, 00:53 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 237
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
InExSu, krosav4ig, Благодарю за идею и за конкретную помощь, осталось за «малым» - «безболезненно» вписать в основной код.
 
Ответить
СообщениеInExSu, krosav4ig, Благодарю за идею и за конкретную помощь, осталось за «малым» - «безболезненно» вписать в основной код.

Автор - Сергей13
Дата добавления - 12.09.2019 в 00:53
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сортировка на основании маркировки наименования (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2019 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!