Удалить повторяющиеся элементы из массива

[bdfy]

нужна функция сокращающая запись вида
"48,50,57,58,53,51,60,62,56,45,44,4 6,46,47,66,61,59,49,63,64,52,65,69, 69,69,69"
до 44-53,56-66,69
т.е порядковое перечисление сокращающая.
почти написал - но не могу удалить повторяющиеся элементы
хотя задача вроде типовая. код брал отсюда
http://www.cyberforum.ru/vba/thread911425.html
С виду все верно - но получаю ошибку несоответствия типа. В чем я ошибся ?

Sub test()
s = "48,50,57,58,53,51,60,62,56,45,44,46,46,47,66,61,59,49,63,64,52,65,69,69,69,69"


Debug.Print сократить_запись_номеров(s)
End Sub
Function getUniq(A() As Integer) As Integer()
Dim R() As Integer
    n& = UBound(A)
    'Debug.Print A
    ReDim R(1 To n&) As Integer
    o& = 0
    For i& = 1 To n&
        x% = A(i&)
        q% = 0
        For j& = 1 To o&
            If R(j&) = x% Then
               q% = -1
               Exit For
            End If
        Next j&
        If q% = 0 Then
           o& = o& + 1
           R(o&) = x%
        End If
    Next i&
    ReDim Preserve R(1 To o&) As Integer
    getUniq = R
End Function
Function сократить_запись_номеров(ByVal s As String) As String

's = "1,2,3,4,5,6,8,7,9,18,10,11,14,15,16,17,19,20,21,22,24,23,50,51,52"

A = Split(s, ",")
res = s



If UBound(A) > 0 Then
    
    'сортируем
    n% = UBound(A)
        Do
           q% = 0
           For i% = 0 To n% - 1
               If CInt(A(i% + 1)) < CInt(A(i%)) Then
                  q% = -1
                  Tmp% = A(i%)
                  A(i%) = A(i% + 1)
                  A(i% + 1) = Tmp%
               End If
           Next i%
           If q% = 0 Then Exit Do
        Loop
    
'Нужно удалить повторяющиеся элементы
A = getUniq(A)


Exit Sub
 For Each x In A
 Debug.Print x
 Next
    
    res = ""
    
    For i = 1 To UBound(A)
    res1 = A(i - 1)
        Do While True
            
           ' Debug.Print a(i) & " " & a(i - 1) & "|" & a(i) - a(i - 1)
            If ((A(i) - A(i - 1) <> 1) Or i >= UBound(A)) Then Exit Do
            i = i + 1
        Loop
        If i = UBound(A) Then i = i + 1
        If res1 = A(i - 1) Then
        res = res & res1 & ","
        Else
        res = res & res1 & "-" & A(i - 1) & ","
        End If
    Next
    res = Left(res, Len(res) - 1)
End If
'Debug.Print res
сократить_запись_номеров = res


End Function

[IgorGO]

Sub Test()
  Const DgtList$ = "48,50,57,58,53,51,60,62,56,45,44,46,46,47,66,61,59,49,63,64,52,65,69,69,69,69"
  Debug.Print ShortDgtList(DgtList)
End Sub

Function ShortDgtList$(s$)
  Dim dct, ar, i&, p&
  Set dct = CreateObject("Scripting.Dictionary"): ar = Split(s, ",")
  For i = LBound(ar) To UBound(ar)
    If Not dct.exists(Val(ar(i))) Then dct.Add Val(ar(i)), i
  Next
  ar = dct.keys:  i = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count
  With Cells(1, i).Resize(UBound(ar), 1)
    .Value = WorksheetFunction.Transpose(ar): .Sort .Cells(1): ar = .Value: .ClearContents
  End With
  s = ar(1, 1): p = 1
  For i = 2 To UBound(ar)
    If ar(i, 1) <> ar(p, 1) + i - p Then
      If i - p > 1 Then s = s & "-" & ar(i - 1, 1)
      s = s & "," & ar(i, 1): p = i
    Else
      If i = UBound(ar) Then s = s & "-" & ar(i, 1)
    End If
  Next
  ShortDgtList = s
End Function

[bdfy]

красивый код. не некорректный
результат
44-53,56-66
т.е теряется 69

а главное мне код этот нужно запускать не из Excel и из под Visio (но тут такого раздела нет), поэтому решение делаю на "чистом" VBA по возможности без объектов Excel. как переработать чтобы это запускалось из любой программы офиса ?

[IgorGO]

ошибка стандартная - не проверял код((
замените:
With Cells(1, i).Resize(UBound(ar) , 1)
на:
With Cells(1, i).Resize(UBound(ar) + 1, 1)
и появиться 69

[bdfy]

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

Почему не работает стандартная функция в моем решении ? В чем моя ошибка ?

[IgorGO]

я не могу это запускать в екселе

а я, по-вашему, в какой среде писал и выполнял этот код?
вот эти 4 строки:

  ar = dct.keys:  i = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count
  With Cells(1, i).Resize(UBound(ar) + 1, 1)
    .Value = WorksheetFunction.Transpose(ar): .Sort .Cells(1): ar = .Value: .ClearContents
  End With

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

[bdfy]

я не могу это запускать в екселе
а я, по-вашему, в какой среде писал и выполнял этот код?
вот эти 4 строки:

вы меня не поняли - ваше решение сделано явно с использованием внутренних функций Excel, которые недоступны для меня, так как я запускаю макрос в MS Visio

[alex77755]

Почему не работает стандартная функция в моем решении ?

разве бейсик не указывает на все ошибки?

Sub test()
s = "48,50,57,58,53,51,60,62,56,45,44,46,46,47,66,61,59,49,63,64,52,65,69,69,69,69"
Debug.Print сократить_запись_номеров(s)
End Sub

Function getUniq(A)
    Dim R() As Integer
        n& = UBound(A)
        'Debug.Print A
        ReDim R(1 To n&) As Integer
        o& = 0
        For i& = 1 To n&
            x% = A(i&)
            q% = 0
            For j& = 1 To o&
                If R(j&) = x% Then
                   q% = -1
                   Exit For
                End If
            Next j&
            If q% = 0 Then
               o& = o& + 1
               R(o&) = x%
            End If
        Next i&
        ReDim Preserve R(1 To o&) As Integer
        getUniq = R
End Function

Function сократить_запись_номеров(ByVal s As String) As String
    A = Split(s, ",")
    res = s
    If UBound(A) > 0 Then
        'сортируем
        n% = UBound(A)
            Do
               q% = 0
               For i% = 0 To n% - 1
                   If CInt(A(i% + 1)) < CInt(A(i%)) Then
                      q% = -1
                      Tmp% = A(i%)
                      A(i%) = A(i% + 1)
                      A(i% + 1) = Tmp%
                   End If
               Next i%
               If q% = 0 Then Exit Do
            Loop
    'Нужно удалить повторяющиеся элементы
    A = getUniq(A)
        res = ""
        For i = 2 To UBound(A)
        res1 = A(i - 1)
            Do While True
               ' Debug.Print a(i) & " " & a(i - 1) & "|" & a(i) - a(i - 1)
                If ((A(i) - A(i - 1) <> 1) Or i >= UBound(A)) Then Exit Do
                i = i + 1
            Loop
            If i = UBound(A) Then i = i + 1
                If res1 = A(i - 1) Then
                res = res & res1 & ","
            Else
                res = res & res1 & "-" & A(i - 1) & ","
            End If
        Next
        res = Left(res, Len(res) - 1)
    End If
    сократить_запись_номеров = res
End Function

[bdfy]

i& x%
Какой то сакральный смысл в значках "&%" есть или нет ?
alex77755
первый элемент массива пропадает в такой реализации
как это поправить ?

[bdfy]

IgorGO
спасибо чуть чуть доработал и стало работать и в Visio
нужно только какой нибудь объект екселя вызвать

Sub Test()
  Const DgtList$ = "1,48,50,57,58,53,51,60,62,56,45,44,46,46,47,66,61,59,49,63,64,52,65,69,69,69,69,70,72"
  Debug.Print ShortDgtList(DgtList)
End Sub

Function ShortDgtList$(s$)

's$ = "1,48,50,57,58,53,51,60,62,56,45,44,46,46,47,66,61,59,49,63,64,52,65,69,69,69,69,70,72"
    Set exwb = GetObject(ThisDocument.Path & "\1.xlsm")
    Set Exws = exwb.Worksheets("t1")


  Dim dct, ar, i&, p&
  Set dct = CreateObject("Scripting.Dictionary"): ar = Split(s, ",")
  

  For i = LBound(ar) To UBound(ar)
    If Not dct.Exists(Val(ar(i))) Then dct.Add Val(ar(i)), i
  Next
  ar = dct.Keys:  i = Exws.UsedRange.Column + Exws.UsedRange.Columns.Count
  With Exws.Cells(1, i).Resize(UBound(ar) + 1, 1)
    .Value = Exws.Application.WorksheetFunction.Transpose(ar): .sort .Cells(1): ar = .Value: .ClearContents
  End With
  s = ar(1, 1): p = 1
  For i = 2 To UBound(ar)
    If ar(i, 1) <> ar(p, 1) + i - p Then
      If i - p > 1 Then s = s & "-" & ar(i - 1, 1)
      s = s & "," & ar(i, 1): p = i
    Else
      If i = UBound(ar) Then s = s & "-" & ar(i, 1)
    End If
  Next
  ShortDgtList = s
  'Debug.Print s
End Function