Visual Basic, .NET, ASP, VBScript
Новости | Примеры | Библиотека кодов | НеЧаВо | VBA | Справочник по VB | Справочник по WinAPI | ActiveX контролы | Статьи по VB | Мастерская разработчика | Форум VBNet | Яndex bar! | Голосование | Полезные программы | Магазин VBNet | Рассылка | Конкурсы | Юмор | Чат | Реклама на VBNet | Автора! | Ссылки | Бета-тестирование | Послать пример на сайт
 

   
   
     

Форум - Общий форум

Страница: 1 | 2 | 3 | 4 | 5 |

 

  Вопрос: Удаление дубликатов из массива Добавлено: 11.11.05 15:04  

Автор вопроса:  AsHeS | ICQ: 229759992 

Ответить

  Ответы Всего ответов: 66  

Номер ответа: 46
Автор ответа:
 Victor



ICQ: 345743490 

Вопросов: 42
Ответов: 385
  Web-сайт: vt-dbnz.narod.ru
 Профиль | | #46 		Добавлено: 19.11.05 00:21
Способ первый. Тупой, без сортировки. Работает за o(n^2) колва элементов.
Public Sub RemoveCopies(ByRef vArr() As String, _
                        ByRef Output() As String)

    Dim RemMarks() As Boolean 'True если элемент надо удалить
    Dim i As Long, j As Long
    Dim n As Long
    ReDim RemMarks(LBound(vArr) To UBound(vArr))
    ReDim Output(LBound(vArr) To UBound(vArr))
    n = LBound(vArr)
    For i = LBound(vArr) To UBound(vArr)
        If Not RemMarks(i) Then
            'Добавить этот элемент
            Output(n) = vArr(n)
            n = n + 1
            'Пометить оставшиеся элементы, которые равны vArr(i), для
удаления
            For j = i + 1 To UBound(vArr)
                If Not RemMarks(i) Then
                    If vArr(j) = vArr(i) Then
                        RemMarks(j) = True
                    End If
                End If
            Next j
        End If
    Next i
    ReDim Preserve Output(LBound(vArr) To n - 1)

End Sub

Сводится к o(n), если в исходном массиве очень много совпадающих элементов.
Выводит результат в массив Output в том порядке, в котором они идут в
исходном массиве (устранив дубликаты). Исходный массив оставляет нетронутым.

Второй способ. Отсортировать, затем пройтись по массиву. Учитывая при этом,
что надо брать очередной элемент только если он отличен от последнего
добавленного.
Sub RemoveCopies2(ByRef vArr() As String, ByRef Output() As String)

    QSort vArr, LBound(vArr), UBound(vArr)

    Dim i As Long
    Dim n As Long
    ReDim Output(LBound(vArr) To UBound(vArr))
    i = LBound(vArr)
    Output(i) = vArr(i)
    n = i + 1
    For i = LBound(vArr) + 1 To UBound(vArr)
        If Not vArr(i) = Output(n - 1) Then
            Output(n) = vArr(i)
            n = n + 1
        End If
    Next i
    ReDim Preserve Output(LBound(vArr) To n - 1)

End Sub

Public Sub QSort(ByRef vArr() As String, _
                 ByVal lngLeft As Long, _
                 ByVal lngRight As Long)

    Dim i As Long
    Dim j As Long
    Dim TestVal As String
    Dim lngMid As Long

    'If lngLeft = dhcMissing Then lngLeft = LBound(varr)
    'If lngRight = dhcMissing Then lngRight = UBound(varr)

    If lngLeft < lngRight Then
        lngMid = (lngLeft + lngRight) \ 2
        TestVal = vArr(lngMid)
        i = lngLeft
        j = lngRight
        Do
            Do While (vArr(i) < TestVal)
                i = i + 1
            Loop
            Do While (vArr(j) > TestVal)
                j = j - 1
            Loop
            If i <= j Then
                SwapStrings vArr(i), vArr(j)
                i = i + 1
                j = j - 1
            End If
        Loop Until i > j
        ' To optimize the sort, always sort the
        ' smallest segment first.
        If j <= lngMid Then
            Call QSort(vArr, lngLeft, j)
            Call QSort(vArr, i, lngRight)
        Else
            Call QSort(vArr, i, lngRight)
            Call QSort(vArr, lngLeft, j)
        End If
    End If

End Sub

Private Sub SwapStrings(ByRef St1 As String, ByRef St2 As String)
    Dim tmp As String
    tmp = St1
    St1 = St2
    St2 = tmp
End Sub

Работает за время o(n*log(n)) (время работы сортировки) почти не зависимо от
начальных данных (хотя может и если массив предварительно отсортирован,
будет работать быстрее). Бяка в том, что исходный массив она не сохраняет, а
сортирует его. А в Output выдает отсортированный без дубликатов.

Примечание. Оценка времени o(...) означает, что время будет зависеть от
количества элементов пропорционально ... при больших количествах элементов.
Например, оценка o(n) означает, что время работы растет пропорционально
количеству элементов, когда n большое.

PS. Протестил эти функции на тривиальном примере. Глюки могут быть - не
гарантирую.
PPS. Знаю, что и данную реализацию QSort, и мои импровизации по удалению
элементов можно ускорить. Но не стал этого делать. Влом.

Ответить

Номер ответа: 47
Автор ответа:
 AsHeS



ICQ: 229759992 

Вопросов: 14
Ответов: 93
  Профиль | | #47 Добавлено: 21.11.05 09:56
Блин (
У мя Бейсик на reDim ругается . В чем проблема может быть ?

Ответить

Номер ответа: 48
Автор ответа:
 AsHeS



ICQ: 229759992 

Вопросов: 14
Ответов: 93
  Профиль | | #48 Добавлено: 22.11.05 15:24
:( Вот уж не думал что запорюсь на такой казалось бы мелочи

Народ , мож кто хоть ссылочку на какие-нибудь примеры видел ? Если да , то напишите плиз

Ответить

Номер ответа: 49
Автор ответа:
 HOOLIGAN



Вопросов: 0
Ответов: 1066
  Профиль | | #49 Добавлено: 22.11.05 17:28
Чтобы можно было сделать ReDim, объявляй массив как Arr() as String. Не указывай сразу размер. Размер укажешь потом как раз в ReDim

Ответить

Номер ответа: 50
Автор ответа:
 AsHeS



ICQ: 229759992 

Вопросов: 14
Ответов: 93
  Профиль | | #50 Добавлено: 24.11.05 10:13
В том и проблема , что если я буду писать
Arr() as String , то у мя тогда в других местах начинают ошибки выпрыгивать .
Мож кто-нить хоть алгоритм какой попроще подскажет . А то я уже на одном месте дофига времени сижу . Мне надо прогу быстрее заканчивать

Ответить

Номер ответа: 51
Автор ответа:
 HOOLIGAN



Вопросов: 0
Ответов: 1066
  Профиль | | #51 Добавлено: 24.11.05 10:50
Дело не в алгоритме. Он может быть любой.
Попробуй сделать так: объяви свой массив глобальным, чтобы из любой процедуры его было видно, и не надо было его передавать как параметр между процедурами.
Public MyArr() As String
А если ты сделаешь локальный массив в какой-то процедуре (он будет располагаться в стеке), то никто тебе естественно не позволит из другой процедуры менять стековый фрейм при ReDim (если действительно на стеке создаётся)

Ответить

Номер ответа: 52
Автор ответа:
 AsHeS



ICQ: 229759992 

Вопросов: 14
Ответов: 93
  Профиль | | #52 Добавлено: 24.11.05 10:58
У меня как бы модуль чем-то похожий на listbox. Он хранит в себе массив со строками . Моя прога кладет данные в массив по одному и получает по 1 .
Мне нужно чтоб моя прога положила инфу в массив , вызвала функцию удаления дубликатов , затем забираем инфу уже в саму прогу . Проблема в том , что у меня в модуле в General Dim list (4096) as string . А если я напишу Dim list () as String , то в функциях добавления у меня начинают вылезать ошибки . В принципе я могу выложить весть код модуля ...

Ответить

Номер ответа: 53
Автор ответа:
 AsHeS



ICQ: 229759992 

Вопросов: 14
Ответов: 93
  Профиль | | #53 Добавлено: 24.11.05 11:01
Dim list(4096) As String
Dim index As Integer
Public lastindex As Integer
Public ordMode As Integer
Public fSortHiToLo As Integer

Public Function AddItem(str$)
list(lastindex + 1) = str
lastindex = lastindex + 1
End Function

Public Function Clear()
lastindex = -1
Do Until list(index) = ""
list(index) = ""
index = index + 1
Loop
index = 0
End Function

Public Function Text(index)
Text = list(index)
End Function
' Вывод всех строк массива
Public Function Debuging()
BDform.Debuging.Clear
index = 0
Do Until list(index) = ""
BDform.Debuging.AddItem list(index)
index = index + 1
Loop
index = 0
End Function

Public Sub DelDuplicate()
' Сортировка
Call SortArray(0, lastindex)
q = 0
' удаляем дубликаты
End Sub

Sub SortArray(iFirst As Integer, iLast As Integer)
    ;Dim vSplit As Variant
 
    If iFirst < iLast Then
        If iLast - iFirst = 1 Then
            If SortCompare(list(iFirst), list(iLast)) > 0 Then
                SortSwap list(iFirst), list(iLast)
            End If
        Else
            ;Dim i As Integer, j As Integer, iRand As Integer
            iRand = GetRandom(iFirst, iLast)
            SortSwap list(iLast), list(iRand)
            vSplit = list(iLast)
            ;Do
                i = iFirst: j = iLast
                ;Do While (i < j) And _
                         SortCompare(list(i), vSplit) <= 0
                    i = i + 1
                Loop
                ;Do While (j > i) And _
                         SortCompare(list(j), vSplit) >= 0
                    j = j - 1
                Loop
                If i < j Then
                    SortSwap list(i), list(j)
                End If
            Loop While i < j
          SortSwap list(i), list(iLast)
            If (i - iFirst) < (iLast - i) Then
                SortArray iFirst, i - 1
                SortArray i + 1, iLast
            Else
                SortArray i + 1, iLast
                SortArray iFirst, i - 1
            End If
        End If
    End If

End Sub

Public Function SortCompare(v1 As Variant, v2 As Variant) As Integer
    If TypeName(v1) <> "String" Then ordMode = ordSortVal
    ;Dim i As Integer
    Select Case ordMode
    Case ordSortVal
        If v1 < v2 Then
            i = -1
        ElseIf v1 = v2 Then
            i = 0
        Else
            i = 1
        End If
    Case ordSortText
        i = StrComp(v1, v2, 1)
    Case ordSortBin
        i = StrComp(v1, v2, 0)
    Case ordSortLen
        If Len(v1) = Len(v2) Then
            If v1 = v2 Then
                i = 0
            ElseIf v1 < v2 Then
                i = -1
            Else
                i = 1
            End If
        ElseIf Len(v1) < Len(v2) Then
            i = -1
        Else
            i = 1
        End If
    End Select
    If fSortHiToLo Then i = -i
    SortCompare = i
End Function

Function GetRandom(iLo As Integer, iHi As Integer) As Integer
    GetRandom = Int(iLo + (Rnd * (iHi - iLo + 1)))
End Function

Sub SortSwap(v1 As Variant, v2 As Variant)
    ;Dim vT As Variant
    vT = v1
    v1 = v2
    v2 = vT
End Sub

Ответить

Номер ответа: 54
Автор ответа:
 HOOLIGAN



Вопросов: 0
Ответов: 1066
  Профиль | | #54 Добавлено: 24.11.05 14:16
Мда...

Несколько советов, если хочешь:
Первая строка должна быть Option Explicit. Возьми это за правило.
Не объявляй переменные и функции как variant без крайней необходимости. Это тормоза и куча ошибок.
Объявляй As String, As Long и т.д.
Не используй имена ф-ций и переменных типа Text или list. Это дефолтные свойства объектов типа TextBox и ListBox. Сам же и будешь потом на эти грабли наступать.

Вот модуль для добавления элементов, удаления дубликатов, уничтожения массива, получения строки из массива, отображения содержимого всего массива:

Option Explicit
Public MyArray() As String


Public Function AddItem(item As String) 'добавление элемента в массив
    Dim ub As Long
    Err.Number = 0
    On Error Resume Next
    ub = UBound(MyArray())
    If Err.Number = 9 Then
        ReDim Preserve MyArray(0 To 0)
    Else
        ReDim Preserve MyArray(0 To UBound(MyArray()) + 1)
    End If
    MyArray(UBound(MyArray())) = item
    Debug.Print UBound(MyArray())
End Function

Public Function Clear()      'удаление массива
    Erase MyArray
End Function

Public Function GetArrayString(index As Long) As String 'получение элемента из массива
    GetArrayString = MyArray(index)
End Function

Public Function ShowArray()     'показать массив
    Dim ub As Long, i As Long
    Err.Number = 0
    On Error Resume Next
    ub = UBound(MyArray())
    If Err.Number = 9 Then
        Debug.Print "Array is empty. Nothing to show"
    Else
        For i = 0 To UBound(MyArray())
            Debug.Print MyArray(i)
        Next i
    End If
End Function

Public Sub DeleteDuplicate()    'удалить дубликаты
    Dim temp_arr() As String
    Dim k As Long, i As Long
    Dim ub As Long
    Err.Number = 0
    On Error Resume Next
    ub = UBound(MyArray())
    If Err.Number = 9 Then Exit Sub
    If ub = 0 Then Exit Sub
    recur_sort MyArray(), 0, UBound(MyArray)
    
    On Error GoTo end_arr
    ReDim temp_arr(LBound(MyArray()) To UBound(MyArray()))
    k = LBound(MyArray())
    For i = LBound(MyArray()) To UBound(MyArray()) - 1
        temp_arr(k) = MyArray(i): k = k + 1
        Do While MyArray(i) = MyArray(i + 1)
            i = i + 1
        Loop
    Next i
end_arr:
    If MyArray(UBound(MyArray())) <> temp_arr(k - 1) Then
        temp_arr(k) = MyArray(UBound(MyArray()))
    End If
    
    ReDim Preserve temp_arr(LBound(MyArray()) To k)
    For i = LBound(temp_arr()) To UBound(temp_arr())
        MyArray(i) = temp_arr(i)
    Next i
    ReDim Preserve MyArray(LBound(temp_arr()) To UBound(temp_arr()))

End Sub

Private Function partition(a() As String, Low As Long, High As Long) As Long
    Dim p As Long, pivot As String, t As String
    Dim i As Long, j As Long
     
    p = Low + ((High - Low) \ 2)
    pivot = a(p)
    a(p) = a(Low)
    i = Low + 1
    j = High
     
    Do While True
        Do While (i < j And (pivot > a(i))):     i = i + 1: Loop
        Do While (j >= i And (a(j) > pivot)):    j = j - 1: Loop
        If (i >= j) Then Exit Do
        t = a(i)
        a(i) = a(j)
        a(j) = t
        j = j - 1
        i = i + 1
    Loop
    a(Low) = a(j)
    a(j) = pivot
     
    partition = j
     
End Function

Private Sub recur_sort(SortArray() As String, Low As Long, High As Long)
    Dim m As Long
     
    Do While Low < High
        m = partition(SortArray(), Low, High)
        If (m - Low <= High - m) Then
            recur_sort SortArray(), Low, m - 1
            Low = m + 1
        Else
            recur_sort SortArray(), m + 1, High
            High = m - 1
        End If
    Loop

End Sub

Ответить

Номер ответа: 55
Автор ответа:
 AsHeS



ICQ: 229759992 

Вопросов: 14
Ответов: 93
  Профиль | | #55 Добавлено: 24.11.05 14:57
Ого !!! Спасибо большое . Щас тестить буду :)
Кстати давно хотел узнать что такое Option Explicit ? Зачем это писать то нужно ?

Ответить

Номер ответа: 56
Автор ответа:
 AndreyMp



ICQ: 237822510 

Вопросов: 28
Ответов: 1182
  Профиль | | #56 Добавлено: 24.11.05 17:51
Это тебя заставит объявлять все переменные явно.:)

Ответить

Номер ответа: 57
Автор ответа:
 Victor



ICQ: 345743490 

Вопросов: 42
Ответов: 385
  Web-сайт: vt-dbnz.narod.ru
 Профиль | | #57 		Добавлено: 25.11.05 00:44
У мя Бейсик на reDim ругается

Закомментируй все редимы, на которые он ругается (в моем примере), сделай альтернативный механизм возвращения длины полученного массива.

Ответить

Номер ответа: 58
Автор ответа:
 AsHeS



ICQ: 229759992 

Вопросов: 14
Ответов: 93
  Профиль | | #58 Добавлено: 25.11.05 12:55
Victor спасибо , но уже не нужно . HOOLIGAN помог :)

Ответить

Номер ответа: 59
Автор ответа:
 AsHeS



ICQ: 229759992 

Вопросов: 14
Ответов: 93
  Профиль | | #59 Добавлено: 25.11.05 14:06
HOOLIGAN проблема , пишет :
Compile Error:
Invalid qualifier
И ссылается на err.Number = 0

Ответить

Номер ответа: 60
Автор ответа:
 AsHeS



ICQ: 229759992 

Вопросов: 14
Ответов: 93
  Профиль | | #60 Добавлено: 25.11.05 15:05
Причем фокус в том что когда у меня 1 форма (часть моей проги) и твой модуль - все ОК . Как только я модуль и форму запускаю в одном проекте со всем остальным - начинает вылезать эта самая ошибка :(

Ответить

Страница: 1 | 2 | 3 | 4 | 5 |

Поиск по форуму



© Copyright 2002-2011 VBNet.RU | Пишите нам