Страницы: Пред. 1 2
RSS
Сортировка данных внутри ячейки
 
Упс. Извините. Там еще и перенос строки в ячейке
Согласие есть продукт при полном непротивлении сторон
 
Цитата
Sanja написал:
нет примера, где в ячейке их надо сортировать
 
Казанский, могу я Вас попросить посмотреть внимательнее на то, что находится внутри ячейки. Там указано не одно значение, а несколько, они идут с переносом строки, как правильно подметил Sanja. Поэтому мое сообщение расположено в правильном месте, т.к. сортировка нужна внутри ячейки, а за примеры, простите - виноват - исправляюсь. Приложил новый файл.
 
Станислав К., двумерный массив, в котором в 1-м столбце размеры одежды , во втором приоритеты сортировки. Сортировать по "приоритетам".
---------
И если хотим, чтобы сортировка была быстрой, то как писал SAS в своем макросе:
- сжигаем пробелы
- по разделителям разбиваем строку на массив значений
- сортируем любым из всевозможных вариантов ("пузырёк" самый медленный из них)
- сцепляем все по-новой и заносим обратно в ячейку.

И если нужно избавиться от дубликатов, то перед сортировкой или после прогоняем массив через словарь
Изменено: oldy7 - 09.01.2018 13:29:44
 
oldy7, спасибо за ответ. Я надеюсь, что смогу разобраться в том, что вы написали.
 
Необходимо отсортировкой внутри ячейки данные прведенного в примере вида по дате (формат "число.месяц" цифрами).
Изменено: Novichok55 - 16.05.2018 23:46:32
 
Посмотрите пример во вложении.
Выделите требуемую ячейку и выполните макрос "mySort".

P.S. Вообще-то, нужно было создать новую тему...
Чем шире угол зрения, тем он тупее.
 
Спасибо. В примере работает как и хотелось.
Но работает только для первой выделенной ячейки. Извините, что в примере не сделал столбец  :( из разных случаев.
Изменено: Novichok55 - 17.05.2018 07:44:57
 
чутка дописал функцию сортировки с которой начинается тема, ввел возможность сортировки не по самим подстрокам, а по результатам применения шаблона регулярного выражения к ним.
Код
' Сортировка подстрок в строке inputString с разделителем withDelimit
' regPattern - шаблон регулярного выражения применяемого к подстрокам перед сортировкой. если не задан сортировка ведется по значениям подстрок
' regSet - флаги регулярного выражения:
'   младший бит - если 0 возвращаемый результат соответствует шаблону, 1 - из подстроки удаляется соответствие шаблону
'   второй бит - (пока только в связке с первым битом =1)
'   третий бит - если 0 поиск до первого совпадения, 1 - поиск по всему тексту
'   четвертый бит - если 0 учитывать регистр, 1 - не учитывать регистр
'   пятый бит - если 0 текст однострочный, 1 - многострочный текст
' theTest - если true функция вернет результаты применения регулярного выражения вместо подстрок
Function SortString(inputString As String, Optional withDelimit As String = " ", Optional regPattern As String = "", Optional regReplace As String = "", Optional regSet As Byte = 0, Optional theTest As Boolean = False) As String
    Dim arrStr() As String, arrBuff() As String
    Dim arrIdx() As Long, i As Long, N As Long
    Dim regEx As Object
    
    arrStr = Split(inputString, withDelimit)
    If regPattern = "" Then
        SortString = Join(SortArr(arrStr), withDelimit)
    Else
        Set regEx = CreateObject("VBScript.RegExp")
        If regSet And 4 Then regEx.Global = True Else regEx.Global = False
        If regSet And 8 Then regEx.IgnoreCase = True Else regEx.IgnoreCase = False
        If regSet And 16 Then regEx.MultiLine = True Else regEx.MultiLine = False
        regEx.Pattern = regPattern
        N = UBound(arrStr)
        ReDim arrBuff(0 To N)
        For i = 0 To N
            If regSet And 1 Then
                If regSet And 2 Then
                    If regEx.Test(arrStr(i)) Then arrBuff(i) = regEx.Replace(regEx.Execute(arrStr(i)).Item(0), regReplace) Else arrBuff(i) = arrStr(i)
                Else
                    If regEx.Test(arrStr(i)) Then arrBuff(i) = regEx.Replace(arrStr(i), regReplace) Else arrBuff(i) = arrStr(i)
                End If
            Else
                If regEx.Test(arrStr(i)) Then arrBuff(i) = regEx.Execute(arrStr(i)).Item(0) Else arrBuff(i) = ""
            End If
        Next i
        arrIdx = SortArrIdx(arrBuff)
        For i = 0 To N
            SortString = SortString & IIf(theTest, arrBuff(arrIdx(i)), arrStr(arrIdx(i))) & IIf(i < N, withDelimit, "")
        Next i
    End If
End Function

Function SortArr(ByVal Arr)
Dim i&, j&, N&, tmp$

If Not IsArray(Arr) Then SortArr = Arr: Exit Function
N = UBound(Arr)
For i = 0 To N - 1
    For j = i + 1 To N
        If IsNumeric(Arr(i)) And IsNumeric(Arr(j)) Then
            If Val(Arr(i)) > Val(Arr(j)) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp
        Else
            If Arr(i) > Arr(j) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp
        End If
Next j, i
SortArr = Arr
End Function

Function SortArrIdx(ByVal Arr)
Dim i&, j&, N&, tmp$, tt&, arrIdx() As Long

If Not IsArray(Arr) Then SortArrIdx = Arr: Exit Function
N = UBound(Arr)
ReDim arrIdx(0 To N)
For i = 0 To N
    arrIdx(i) = i
Next i
For i = 0 To N - 1
    For j = i + 1 To N
        If IsNumeric(Arr(i)) And IsNumeric(Arr(j)) Then
            If Val(Arr(i)) > Val(Arr(j)) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
        Else
            If Arr(i) > Arr(j) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
        End If
Next j, i
SortArrIdx = arrIdx
End Function
новая версия в сообщении #50
Изменено: DenSyo - 24.05.2018 10:49:33
 
Проверяйте.
Откройте файл и выполните макрос "mySort".
Чем шире угол зрения, тем он тупее.
 
Спасибо работает. Но опять нашлось что-то...нельзя ли убрать из макроса привязку к первому столбцу, чтоб можно было и 4й столбец с подобным содержимым отсортировать?
Всё на что меня хватило
Код
For k = 4 To Cells(Rows.Count, 1).End(xlUp).Row
но не сработало :(
Изменено: Novichok55 - 17.05.2018 09:38:26
 
В строках кода
Код
Cells(Rows.Count, 1).End(xlUp).Row
'
s = Cells(k, 1)
'
Cells(k, 1) = Join(a, "; ")
замените "1" на номер требуемого столбца.
Чем шире угол зрения, тем он тупее.
 
Novichok55, обновил функцию сортировки и выложенный мной файл в предыдущем сообщении, функция =SortString(A1;"; ";"(\d{2}).(\d{2})";"$2$1";3) работает как вам надо.

toAll, вообще, получилась достаточно универсальная функция сортировки, используя регулярные выражения можно работать с самыми разными данными.  
 
SAS888 спасибо, работает! :)

DenSyo большое спасибо, что обратили на мой вопрос внимание. Сегодня попробую.
Изменено: Novichok55 - 17.05.2018 10:25:14
 
DenSyo к сожалению мой уровень даже не позволяет найти куда в тот код вставить
Код
=SortString(A1;"; ";"(\d{2}).(\d{2})";"$2$1";3)
понятное дело, что попробовал вот тут примоститься
Код
SortString = SortString & IIf(theTest, arrBuff(arrIdx(i)), arrStr(arrIdx(i))) & IIf(i < N, withDelimit, "")
но не прокатило, больше не вижу вариантов :(
Да и к тому же, даже если я сумею настроить функцию, то вариант через Мастер функций мне не очень подходит, нужен макрос привязанный к этой функции, а это для меня космос :(
 
Цитата
Novichok55 написал:
к сожалению мой уровень даже не позволяет найти куда в тот код вставить
в любую ячейку кроме А1 на первом листе не пробовали? смелее

кстати! я же еще вчера ваш файл мною измененный приложил в котором наглядно показано как работает функция...
Изменено: DenSyo - 18.05.2018 02:56:34
 
Взял ваш пример.
Вставляю формулу взятую на форуме в любую другую ячейку этого примера получаю "Знач", Excel2007.

Взял формулу прямо с примера, работает :)

Изменено: Novichok55 - 18.05.2018 22:08:27
 
она только в примере и будет работать, т.к. в нем в вба внесена эта самая функция. либо самостоятельно вставляем функцию из сообщения #39 в модуль проекта и она так же станет работать)
 
Спасибо за разъяснение. Альтернативный вариант будет.
 
обновление функции сортировки строк. более разумно применяются регулярки, расширен функционал, в том числе внесена функция натурального сравнения. основные моменты в комментариях к функции плюс примеры в файле.
Код
' Сортировка подстрок в строке inputString с разделителем withDelimit
' regPattern - шаблон регулярного выражения применяемого к подстрокам перед сортировкой. если не задан сортировка ведется по значениям подстрок
' regReplace - строка регулярного выражения для замены
' regSet - флаги регулярного выражения (по умолчанию 0):
'   младший бит - если 0 возвращаемый результат соответствует шаблону, 1 - из подстроки удаляется соответствие шаблону
'   второй бит
'   третий бит - если 0 поиск до первого совпадения, 1 - поиск по всему тексту
'   четвертый бит - если 0 учитывать регистр, 1 - не учитывать регистр
'   пятый бит - если 0 текст однострочный, 1 - многострочный текст
'   шестой бит
'   седьмой бит - если 1 используется серия замен в строке inputString вместо регулярного выражения:
'     строка regPattern задает набор искомых строк разделенных разделителем withDelimit,
'     строка regReplace набор строк замены с разделителем withDelimit соответствующий порядку строк regPattern
'     третий и четвертый биты имеют такое же значение как для регулярного выражения
'   восьмой бит - если 1 сортировка подстрок в строке inputString производится по индексам в строке regPattern заданным через разделитель withDelimit
'     все остальные биты в regSet и другие флаги не имеют значения
' sortSet - флаги сортировки (по умолчанию 0):
'   младший бит - если 1 сортировка по убыванию
'   второй бит - если 1 использовать натуральное сравнение
' returnSet - флаг возвращаемого результата (по умолчанию 0):
'   0 - отсортированные исходные подстроки
'   1 - отсортированные подстроки после применения шаблона регулярного выражения
'   2 - подстроки после применения шаблона регулярного выражения в исходном порядке
'   3 - индексы исходных подстрок в отсортированном порядке
Function SortString(inputString As String, Optional withDelimit As String = " ", Optional regPattern As String = "", Optional regReplace As String = "", Optional regSet As Byte = 0, Optional sortSet As Byte = 0, Optional returnSet As Byte = 0) As String

    Dim arrStr() As String, arrBuff() As String, s As String, arrFind() As String, arrRep() As String
    Dim arrIdx() As Long, i As Long, N As Long, r As Long, j As Long
    Dim regEx As Object, regItems As Object, rItem As Object
    
    arrStr = Split(inputString, withDelimit)
    N = UBound(arrStr)
    If regPattern = "" Then
        SortString = Join(SortArrIdx(arrStr, IIf(sortSet And 1, 1, 0) + IIf(sortSet And 2, 2, 0)), withDelimit)
    ElseIf regSet And 128 Then
        arrBuff = Split(regPattern, withDelimit)
        If UBound(arrBuff) < N Then ReDim Preserve arrBuff(0 To N)
        For i = 0 To N
            If arrBuff(i) > "" Then If IsNumeric(arrBuff(i)) Then If CLng(arrBuff(i)) <= N + 1 And CLng(arrBuff(i)) > 0 Then SortString = SortString & arrStr(CLng(arrBuff(i)) - 1)
            If i < N Then SortString = SortString & withDelimit
        Next i
    Else
        If regSet And 64 Then
            arrFind = Split(regPattern, withDelimit)
            arrRep = Split(regReplace, withDelimit)
            r = UBound(arrFind)
            If UBound(arrRep) < r Then ReDim Preserve arrRep(0 To r)
        Else
            Set regEx = CreateObject("VBScript.RegExp")
            If regSet And 4 Then regEx.Global = True Else regEx.Global = False
            If regSet And 8 Then regEx.IgnoreCase = True Else regEx.IgnoreCase = False
            If regSet And 16 Then regEx.MultiLine = True Else regEx.MultiLine = False
            regEx.Pattern = regPattern
        End If
        ReDim arrBuff(0 To N)
        For i = 0 To N
            If regSet And 64 Then
                arrBuff(i) = arrStr(i)
                For j = 0 To r
                    arrBuff(i) = Replace(arrBuff(i), arrFind(j), arrRep(j), 1, IIf(regSet And 4, -1, 1), IIf(regSet And 8, vbTextCompare, vbBinaryCompare))
                Next j
            Else
                If regEx.Test(arrStr(i)) Then
                    If regSet And 4 Then
                        Set regItems = regEx.Execute(arrStr(i))
                        s = ""
                        For Each rItem In regItems
                            s = s & rItem
                        Next rItem
                    Else
                        s = regEx.Execute(arrStr(i)).Item(0)
                    End If
                    If regSet And 1 Then arrBuff(i) = regEx.Replace(arrStr(i), regReplace) Else arrBuff(i) = IIf(regReplace = "", s, regEx.Replace(s, regReplace))
                Else
                    If regSet And 1 Then arrBuff(i) = arrStr(i) Else arrBuff(i) = ""
                End If
            End If
        Next i
        If returnSet = 2 Then
            SortString = Join(arrBuff, withDelimit)
        Else
            arrIdx = SortArrIdx(arrBuff, 16 + IIf(sortSet And 1, 1, 0) + IIf(sortSet And 2, 2, 0))
            For i = 0 To N
                SortString = SortString & IIf(returnSet = 1, arrBuff(arrIdx(i)), IIf(returnSet = 3, arrIdx(i) + 1, arrStr(arrIdx(i)))) & IIf(i < N, withDelimit, "")
            Next i
        End If
    End If
End Function

Function SortArrIdx(ByVal Arr, Optional keySet As Byte = 0)
Dim i&, j&, N&, tmp$, tt&, arrIdx() As Long

If Not IsArray(Arr) Then SortArrIdx = Arr: Exit Function
N = UBound(Arr)
ReDim arrIdx(0 To N)
For i = 0 To N
    arrIdx(i) = i
Next i
If N > 0 Then
    If keySet And 1 Then
        For i = N To 1 Step -1
            For j = i - 1 To 0 Step -1
                If IsNumeric(Arr(i)) And IsNumeric(Arr(j)) Then
                    If Val(Arr(i)) > Val(Arr(j)) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
                Else
                    If keySet And 2 Then
                        If CompareNaturale(Arr(i), Arr(j)) = 1 Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
                    Else
                        If Arr(i) > Arr(j) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
                    End If
                End If
        Next j, i
    Else
        For i = 0 To N - 1
            For j = i + 1 To N
                If IsNumeric(Arr(i)) And IsNumeric(Arr(j)) Then
                    If Val(Arr(i)) > Val(Arr(j)) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
                Else
                    If keySet And 2 Then
                        If CompareNaturale(Arr(i), Arr(j)) = 1 Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
                    Else
                        If Arr(i) > Arr(j) Then tmp = Arr(i): Arr(i) = Arr(j): Arr(j) = tmp: tt = arrIdx(j): arrIdx(j) = arrIdx(i): arrIdx(i) = tt
                    End If
                End If
        Next j, i
    End If
End If
If keySet And 16 Then SortArrIdx = arrIdx Else SortArrIdx = Arr
End Function

' функция натурального сравнения, возвращает номер большего аргумента либо 0 в случае равенства
' при сравнении чисел в строках учитывается знак минус, знак точки и региональный знак точки (запятая)
Function CompareNaturale(ByVal str1 As String, ByVal str2 As String) As Integer
    Dim i As Long, k As Long, k1 As Long, k2 As Long
    Dim s1() As String, s2() As String, dsep As String
    Dim v1 As Variant, v2 As Variant
    Dim nn As Boolean
    
    If str1 = str2 Then
        CompareNaturale = 0
    Else
        If str1 Like "*#*" And str2 Like "*#*" Then
            dsep = Application.International(xlDecimalSeparator)
            k1 = 1
            ReDim Preserve s1(0 To k1)
            If IsNumeric(Left(str1, 1)) Then nn = True Else nn = False
            For i = 1 To Len(str1)
                If IsNumeric(Mid(str1, i, 1)) Then
                    If Not nn Then
                        k1 = k1 + 1
                        ReDim Preserve s1(0 To k1)
                        nn = True
                        If LTrim(Right(s1(k1 - 1), 2)) = "-" And Not (IsNumeric(s1(k1 - 2)) And Len(s1(k1 - 1)) = 1) Then
                            s1(k1 - 1) = Left(s1(k1 - 1), Len(s1(k1 - 1)) - 1)
                            s1(k1) = "-"
                        End If
                    End If
                Else
                    If nn Then
                        k1 = k1 + 1
                        ReDim Preserve s1(0 To k1)
                        nn = False
                    End If
                End If
                s1(k1) = s1(k1) & Mid(str1, i, 1)
            Next i
            k2 = 1
            ReDim Preserve s2(0 To k2)
            If IsNumeric(Left(str2, 1)) Then nn = True Else nn = False
            For i = 1 To Len(str2)
                If IsNumeric(Mid(str2, i, 1)) Then
                    If Not nn Then
                        k2 = k2 + 1
                        ReDim Preserve s2(0 To k2)
                        nn = True
                        If LTrim(Right(s2(k2 - 1), 2)) = "-" And Not (IsNumeric(s2(k2 - 2)) And Len(s2(k2 - 1)) = 1) Then
                            s2(k2 - 1) = Left(s2(k2 - 1), Len(s2(k2 - 1)) - 1)
                            s2(k2) = "-"
                        End If
                    End If
                Else
                    If nn Then
                        k2 = k2 + 1
                        ReDim Preserve s2(0 To k2)
                        nn = False
                    End If
                End If
                s2(k2) = s2(k2) & Mid(str2, i, 1)
            Next i
            k = IIf(k1 < k2, k1, k2)
            For i = 1 To k
                If s1(i) <> s2(i) Then
                    If IsNumeric(s1(i)) And IsNumeric(s2(i)) Then
                        v1 = CLng(s1(i))
                        v2 = CLng(s2(i))
                        If i > 1 Then
                            If Replace(Trim(s1(i - 1)), ".", dsep) = dsep Then
                                v1 = CDbl("0" & dsep & s1(i))
                                If i > 2 Then If IsNumeric(s1(i - 2)) Then If CLng(s1(i - 2)) < 0 Then v1 = 0 - v1
                            End If
                            If Replace(Trim(s2(i - 1)), ".", dsep) = dsep Then
                                v2 = CDbl("0" & dsep & s2(i))
                                If i > 2 Then If IsNumeric(s2(i - 2)) Then If CLng(s2(i - 2)) < 0 Then v2 = 0 - v2
                            End If
                        End If
                        If v1 <> v2 Then
                            If v1 > v2 Then CompareNaturale = 1 Else CompareNaturale = 2
                        Else
                            If s1(i) > s2(i) Then CompareNaturale = 1 Else CompareNaturale = 2
                        End If
                    Else
                        If s1(i) > s2(i) Then CompareNaturale = 1 Else CompareNaturale = 2
                    End If
                    Exit For
                Else
                    If i = k Then
                        If k1 = k2 Then CompareNaturale = 0 Else If k1 > k2 Then CompareNaturale = 1 Else CompareNaturale = 2
                    End If
                End If
            Next i
        Else
            If str1 > str2 Then CompareNaturale = 1 Else CompareNaturale = 2
        End If
    End If
End Function
флаги в ключах функции можно набирать на калькуляторе в режиме BIN от старшего к младшему и перевести затем в DEC. можно пользоваться функцией перевода бинарного значения в десятичное как в приложенном файле последний пример. либо включать биты в ключе таким суммированием: 1 (первый, младший бит) + 2 (второй бит) + 4 (третий бит) + 8 (четвертый бит) + 16 (пятый бит) + 32 (шестой бит) + 64 (седьмой бит) + 128 (восьмой бит)

какие идеи будут по расширению функционала? какие-то иные варианты применения регулярок или действий над строками?..
Изменено: DenSyo - 24.05.2018 11:55:51
Страницы: Пред. 1 2
Наверх