макрос Сортировка по алфавиту (Calc)

[sokol92]

Напишу, когда появится время.

[timal1234]

Напишу, когда появится время.

Хорошо, буду ждать.

не совсем... сначала должны идти английские наименования

записываем массив в диапазон Calc на каком-нибудь скрытом листе, сортируем в Calc, забираем результат.

и ещё тогда вопрос, как сделать скрытый лист через макрос или можно просто вручную создать лист и скрыть его?

[sokol92]

Сделал первую версию. Потестируйте, пожалуйста.
Пример вызова - TestSort.
Пока не реализована сортировка букв кириллицы после букв латинского алфавита. Добавлю позднее.

Код Выделить Развернуть

' lang:ru
' Натуральная сортировка массива.
' Параметры:
' arr    - одномерный массив для сортировки.
' oSheet - вспомогательный лист Calc на котором производится сортировка.
'
' Возвращает отсортированный в соответствии с правилами "Natural sort" массив.
' При сортировке даты сортируются как соответствующие числа, false/true как 0/1,
' пустые значения как текстовые строки длины 0.
' Максимальное число элементов массива определяется как число строк листа Calc.
Function SortNatural(ByVal arr, Optional ByVal oSheet As Object)
  Dim i As Long, i1 As Long, i2 As Long, bTemp As Boolean, aData, t As Long, v, res
  Dim oDoc As Object, oRange as Object, props1(0) As New com.sun.star.beans.PropertyValue
  Dim oDisp as Object, props(4) as new com.sun.star.beans.PropertyValue
 
  If IsMissing(oSheet) Then oSheet=Nothing
  i1=LBound(arr)
  i2=UBound(arr)
  If i2<i1 Then  ' пустой массив
    SortNatural=arr
    Exit Function
  End If 
 
  ReDim aData(i2-i1)
  For i=i1 To i2
    v=arr(i)
    t=VarType(v)
    If t=V_DATE Or t=V_CURRENCY Then
      v=CDbl(v)
    ElseIf t=11 Then  ' Boolean
      v=Iif(v, 1, 0)
    ElseIf t=V_EMPTY Or t=V_NULL Then
      v=""
    End If   
   
    aData(i-i1)=Array(v, i)
  Next i
 
  If oSheet Is Nothing Then
    props1(0).Name="Hidden"
    props1(0).Value=True  ' ???
    oDoc = StarDesktop.LoadComponentFromUrl("private:factory/scalc","_default",0, props1)
    oSheet=oDoc.Sheets(0)
    bTemp=True
  Else 
    oDoc=oSheet.DrawPage.Forms.Parent
  End If
 
  oRange=oSheet.GetCellRangebyPosition(0, 0, 1, i2-i1)
  oRange.setDataArray aData
  oDoc.CurrentController.Select oRange
 
  props(0).Name = "ByRows"
  props(0).Value = true
  props(1).Name = "HasHeader"
  props(1).Value = false
  props(2).Name = "NaturalSort"
  props(2).Value = true
  props(3).Name = "Col1"
  props(3).Value = 1
  props(4).Name = "Ascending1"
  props(4).Value = true

  oDisp = createUnoService("com.sun.star.frame.DispatchHelper")
  oDisp.executeDispatch(oDoc.CurrentController.Frame, ".uno:DataSort", "", 0, props())
 
  aData=oRange.DataArray  ' отсортированный диапазон
 
  ReDim res(i1 To i2)
  For i=i1 To i2
    res(i)=arr(aData(i-i1)(1))
  Next i
  SortNatural=res
 
  If bTemp Then oDoc.Close True 
End Function

Sub TestSort
  Dim arr, res
  arr=Array("MDR-60-12", "MDR-60-12", "MDR-60-7", "MDR-100-5", "Кириллица")
  res=SortNatural(arr)
End Sub

[timal1234]

Сделал первую версию. Потестируйте, пожалуйста.

Да, эта часть вроде работает.
Спасибо!

Пока не реализована сортировка букв кириллицы после букв латинского алфавита. Добавлю позднее.

буду ждать

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

[sokol92]

Я учту возможность работы с двумерными массивами и массивами массивов.

[timal1234]

Я учту возможность работы с двумерными массивами и массивами массивов.

Было бы очень хорошо 

[timal1234]

Я учту возможность работы с двумерными массивами и массивами массивов.

почитал тут форумы.... массив у меня двумерный....

не могу найти, как для натуральной сортировки включить Язык - Английский через макрос...

[sokol92]

почитал тут форумы.... массив у меня двумерный....

нее могу найти, как для натуральной сортировки включить Язык - Английский через макрос...

Мы тоже форум, так что есть шанс исправить это. 

[sokol92]

Вторая версия.
Количество параметров выросло, пришлось добавить массив параметров.
Макрос для тестирования основной функции SortByCalc - TestSortByCalc. Попробуйте "погонять" при разных значениях исходного массива и параметров.

Код Выделить Развернуть

Option Explicit

' lang:ru
' Сортировка массива с помощью вызова интерфейсов Calc.
' Параметры:
' arr     Массив для сортировки: одномерный, двумерный, массив массивов.
' aParams Массив параметров: параметр1, значение1, ...
'
' Поиск значения параметра в aParams производится регистронезависимо.
' Обрабатываются следующие значения параметров:
' Locale   локаль для сортировки текстов. Может быть задана как структура com.sun.star.lang.Locale, как массив (Language, Country),
'          или строка Language-Country (можно использовать и знак подчеркивания).
' Fields   номер поля или массив номеров полей (от 1), по которым производится сортировка. Номер поля можно задавать и как текст. Если
'          необходима сортировка по убыванию, то к имени нужно добавить суффикс D.
' Natural  если True, то выполняется "натуральная" сортировка.
' RetType  если 0 (умолчание), то возвращается отсортированный массив, 1 - массив индексов элементов исходного массива.
' Sheet    (объект) вспомогательный лист Calc на котором производится сортировка.
' 
' При сортировке даты сортируются как соответствующие числа, false/true как 0/1,
' пустые значения как текстовые строки длины 0.
' Максимальное число элементов массива определяется как число строк листа Calc.
' Строки массива, имеющие совпадающие для сортировки значения, помешаются в результат в исходном (до сортировки) порядке.
'
' При неудаче возвращается целое число (не массив!) с номером ошибки:
' 1 - параметр arr не является массивом.
' 2   массив имеет размерность, большую 2
Function SortByCalc(ByVal arr, Optional ByVal aParams)
  Dim i As Long, i1 As Long, i2 As Long, j1 As Long, j2 As Long
  Dim bTemp As Boolean, aData, t As Long, v, v2, res, arr2
  Dim oDoc As Object, oRange as Object, oSheet as Object, props1(0) As New com.sun.star.beans.PropertyValue
  Dim oDisp as Object, props(4) as new com.sun.star.beans.PropertyValue
  Dim oDBRange As Object, sortDesc
  Dim oSortFields(0) as new com.sun.star.table.TableSortField
 
  Dim bNatural As Boolean   ' признак натуральной сортировки
  Dim opt As Long           ' 0 - одномерный массив, 1 массив массивов, 2 двумерный массив
  Dim oLocale As New com.sun.star.lang.Locale
  Dim aFields, iField As Long, bDesc As Boolean, row as Long, column As Long
  If IsMissing(aParams) Then aParams=Array()
 
  If Not IsArray(arr) Then  ' параметр arr не является массивом
    SortByCalc=1
    Exit Function
  End If
 
  oSheet=GetParam(aParams, "Sheet", Nothing)
 
  bNatural=CBool(GetParam(aParams, "Natural", False))
 
  v=GetParam(aParams, "Locale", "")
  If IsUnoStruct(v) Then
    oLocale=v
  Else
    If Not IsArray(v) Then v=Split(Replace(v, "_", "-"), "-") 
    If UBound(v)>=0 Then oLocale.Language=v(0)
    If UBound(v)>=1 Then oLocale.Country=v(1)
  End If 
 
  i1=LBound(arr, 1) ' границы массива 
  i2=UBound(arr, 1)
 
  If i2<i1 Then  ' пустой массив
    SortByCalc=arr
    Exit Function
  End If 
 
  i=GetDims(arr)
  If i>2 Then
    SortByCalc=2   ' массив имеет размерность, большую 2
    Exit Function
  End If
 
  If i=2 Then
    opt=2
  ElseIf IsArray(arr(i1)) Then
    opt=1
  Else
    opt=0
  End If     
   
  aFields=GetParam(aParams, "Fields", 1)
  If Not IsArray(aFields) Then aFields=Array(aFields)
 
  If oSheet Is Nothing Then
    props1(0).Name="Hidden"
    props1(0).Value=True  ' ???
    oDoc = StarDesktop.LoadComponentFromUrl("private:factory/scalc","_default",0, props1)
    oSheet=oDoc.Sheets(0)
    bTemp=True
  Else 
    oDoc=oSheet.DrawPage.Forms.Parent
  End If
 
  oRange=oSheet.GetCellRangebyPosition(0, 0, 1, i2-i1)   ' диапазон ячеек для сортировки
 
  If oLocale.Language<>"" Then    ' задана локаль для сортировки
    v="temp_SortByCalc"
    With oDoc.DataBaseRanges
      If .hasByName(v) Then .renoveByName(v)
      .addNewByName V, oRange.RangeAddress
      oDBRange=.getByName(v)
    End With
   
    oSortFields(0).CollatorLocale=oLocale
    sortDesc=oDBRange.SortDescriptor
    For i=LBound(sortDesc) To UBound(sortDesc)
      If sortDesc(i).Name="SortFields" Then
        sortDesc(i).Value=oSortFields
        Exit For
      End If
    Next i
   
    oRange.Sort sortDesc ' сортируем пустой диапазон!
  End If
 
 
  ' Цикл по номерам полей сортировки.
  ' В шаге цикла производится сортировка по одному полю массива.
  ' Массив res содержит индексы массива arr по возрастанию значения полей сортировки.
 
  ReDim res(i1 To i2)   ' первоначальный порядок индексов
  For i=i1 To i2
    res(i)=i
  Next i
 
  For iField=Ubound(aFields) To LBound(aFields) Step -1
   
    v2=aFields(iField)
    If Ucase(Right(v2, 1))="D" Then  ' сортировка по убыванию
      bDesc=True
      v2=Left(v2, Len(v2)-1)
    Else
      bDesc=False
    End If
   
    Column=CLng(v2)-1   ' нумерация от 0
 
    ' aData - массив для занесения в диапазон ячеек
    ReDim aData(i2-i1)
    For i=i1 To i2
      ' v - значение элемента массива для сортировки
      row=res(i)
      If opt=2 Then            ' двумерный массив
        v=arr(row, column)  
      ElseIf opt=1 Then
        v=arr(row)(column)  ' массив массивов
      Else                    
        v=arr(row)
      End If
     
      t=VarType(v)
      If t=V_DATE Or t=V_CURRENCY Then
        v=CDbl(v)
      ElseIf t=11 Then  ' Boolean
        v=Iif(v, 1, 0)
      ElseIf t=V_EMPTY Or t=V_NULL Then
        v=""
      End If   
     
      aData(i-i1)=Array(v, row)   ' значение для сортировки и индекс элемента массива
    Next i
 
    oRange=oSheet.GetCellRangebyPosition(0, 0, 1, i2-i1)
    oRange.setDataArray aData
    oDoc.CurrentController.Select oRange
 
    props(0).Name = "ByRows"
    props(0).Value = True
    props(1).Name = "HasHeader"
    props(1).Value = False
    props(2).Name = "NaturalSort"
    props(2).Value = bNatural
    props(3).Name = "Col1"
    props(3).Value = 1
    props(4).Name = "Ascending1"
    props(4).Value = (Not bDesc)

    oDisp = createUnoService("com.sun.star.frame.DispatchHelper")
    oDisp.executeDispatch(oDoc.CurrentController.Frame, ".uno:DataSort", "", 0, props())
 
    aData=oRange.DataArray  ' отсортированный диапазон
   
    For i=i1 To i2
      res(i)=aData(i-i1)(1)
    Next i
  Next iField 
 
  ' Возвращаем результат сортировки.
  If GetParam(aParams, "RetType", 0) = 1 Then  ' возвращаем массив индексов
    SortByCalc=res
   
  Else  '                                      ' возвращаем массив значений
    If opt=2 Then   ' двумерный массив
      j1=LBound(arr, 2)
      j2=UBound(arr, 2)         
      ReDim arr2(i1 To i2, j1 To J2)
      For i=i1 To i2
        For column=j1 To j2
          arr2(i, column)=arr(res(i), column)
        Next column
      Next i
   
    Else            ' одномерный массив
      ReDim arr2(i1 To i2)
      For i=i1 To i2
        arr2(i)=arr(res(i))
      Next i
    End If
   
    SortByCalc=arr2        
  End If
 
  If bTemp Then oDoc.Close True 
End Function


Function GetParam(Byval aParams, Byval paramName As String, ByVal default)
  Dim i As Long
 
  For i=LBound(aParams) To UBound(aParams) Step 2
    If LCase(aParams(i))=LCase(paramName) Then
      GetParam=aParams(i+1)
      Exit Function
    End If
  Next i   
 
  GetParam=default
End Function


' Возвращает число измерений массива
Function GetDims(arr)
  Dim i As Long, j As Long
  On Error GoTo ErrLabel
  For i=0 To 99
    j=UBound(arr, i+1)
  Next i 
 
ErrLabel:
  GetDims=i
End Function

' Показывает Msgbox c результатом сортировки
Sub ShowArr(Byval arr, Byval title As String)
  Dim i As Long, j as Long, i1 as Long, i2 as Long, s As String, s2 As String
  i1=LBound(arr)
  i2=UBound(arr)
  If GetDims(arr)=1 Then
    If IsArray(arr(i1)) Then  ' массив массивов
      For i=i1 To i2
        s2=""
        For j=LBound(arr(i)) To UBound(arr(i))
          s2=Iif(s2="", s2, s2 & "; ") & arr(i)(j)
        Next j
        s=s & Chr(10) & s2 
      Next i
     
    Else
      s=Join(arr, Chr(10))
    End If
 
  Else  ' двумерный массив   
    For i=i1 To i2
      s2=""
      For j=LBound(arr, 2) To UBound(arr, 2)
        s2=Iif(s2="", s2, s2 & "; ") & arr(i, j)
      Next j
      s=s & Chr(10) & s2 
    Next i
  End If
 
  MsgBox s,,title
 
End Sub

Sub TestSortByCalc
  Dim arr, res, res2, aParams, title As String, arr2, i As Long, j As Long
  arr=Array(Array(1, "MDR-60-12"), Array(2, "MDR-60-12"), Array(3, "MDR-60-7"), Array(4, "MDR-100-5"), Array(5, "Кириллица"))
  aParams=Array("Natural", True, "Locale", "en-US", "Fields", Array(2, "1D"))
 
  res=SortByCalc(arr, aParams)
  ShowArr res, "Массив массивов. Натуральная сортировка, en-US, поля сортировки: 2, 1D"
 
  ' Двумерный массив
  ReDim arr2(0 To Ubound(arr), 0 To Ubound(arr(0)))
  For i=Lbound(arr2, 1) To Ubound(arr2, 1)
    For j=Lbound(arr2, 2) To Ubound(arr2, 2)
      arr2(i, j)=arr(i)(j)
    Next j
  Next i
 
  res2=SortByCalc(arr2, aParams)
  ShowArr res2, "Двумерный массив. Натуральная сортировка, en-US, поля сортировки: 2, 1D"
End Sub

[timal1234]

Вторая версия.
Попробуйте "погонять" при разных значениях исходного массива и параметров.

Спасибо!
Буду тестировать.

[timal1234]

Вторая версия.
Попробуйте "погонять" при разных значениях исходного массива и параметров.

Спасибо!
Буду тестировать.

децимальные номера сортирует не так, как хотелось бы

[sokol92]

Мне кажется, я могу объяснить логику срабатывания логической сортировки в LO.

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

Что в примере противоречит этому?

[timal1234]

Мне кажется, я могу объяснить логику срабатывания логической сортировки в LO.

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

Что в примере противоречит этому?

а я и не говорю, что противоречит.
я говорю: не так, как хотелось бы.


по человеческой логике "ЕАМ.123" должно быть раньше "ЕАМ5.123"

[timal1234]

вопрос, как мне это победить?

[mikekaganski]

децимальные номера

Что это такое? Неужели нельзя использовать слова, имеющиеся в языке? Если Вы используете слово, которое сами придумали, никто не знает, что оно означает в Вашей голове. Даже если имеются ввиду "десятичные номера" - во-первых, это не то же самое, что и номера с десятичной точкой, а во-вторых, на приведённом вами скриншоте "не так как хотелось бы" сортируются не "номера", а строки перед номерами (ЕАМ. против ЕАМ).

Ваш алгоритм должен сначала обработать строки: унифицировать разделители, отсутствие разделителя превратить в отдельный разделитель (сортирующийся после обычного разделителя). Только после этого сортировать.