На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
! Правила раздела Visual Basic: Общие вопросы
Здесь обсуждаются вопросы по языку Visual Basic 1-6 (а так же по схожим языкам, как, например, PowerBASIC).
Вопросы по Visual Basic .NET (это который входит в состав Visual Studio 2002/2003/2005/2008+, для тех, кто не в курсе) обсуждаются в разделе .NET.

Обратите внимание:
1. Прежде чем начать новую тему или отправить сообщение, убедитесь, что Вы не нарушаете правил форума!
2. Обязательно воспользуйтесь поиском. Возможно, Ваш вопрос уже обсуждали. Полезные ссылки приведены ниже.
3. Темы с просьбой выполнить какую-либо работу за автора в этом разделе не обсуждаются. Студенты, вам сюда: ПОМОЩЬ СТУДЕНТАМ!
4. Используйте теги [ code=vba ] ...текст программы... [ /code ] для выделения текста программы подсветкой.
5. Помните, здесь телепатов нет. Формулируйте свой вопрос максимально грамотно и чётко: Как правильно задавать вопросы
6. Запрещено отвечать в темы месячной (и более) давности, без веских на то причин.

Полезные ссылки:
user posted image FAQ Сайта user posted image FAQ Раздела user posted image Кладовка user posted image Наши Исходники user posted image API-Guide user posted image Поиск по Разделу user posted image MSDN Library Online user posted image Google

Ваше мнение о модераторах: user posted image SCINER, user posted image B.V.
Модераторы: SCINER, B.V.
  
> Сортировка , работает некорректно
    Доброго времени суток! Есть сортировка. Она работает идеально только в случае, когда один столбец (в массиве кроме числе больше ничего нет).
    У меня данные в таком виде:

    массив dat_ls
    01.01.2028 01.01.2017 123
    01.02.2014 05.07.2014 456
    01.05.2026 07.01.2019 000

    Надо отсортировать данные по 1-му или 2-му столбцу так, чтобы данные сохранились (как в EXCEL).
    А данные сохраняются только в том столбце, который сортируется.

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

    ExpandedWrap disabled
      'Запуск сортировки--------------------------------------
       
      Dim dt1() As String
       
      dt1 = SortArrayMinMaxZnV1(dat_ls, 0, 1, 0)
       
      '//Запуск сортировки------------------------------------
       
      'Сам код--------------------------------------
       
      Public Function SortArrayMinMaxZnV1(ByRef in_arr() As String, ByVal MinMax As LogVar, ByVal NmbStlb As Byte, ByVal SW_Type As Boolean) As String()
       
      'SW_Type=1 - сортировка по числам, 0- по дате
       
      Dim max_val As Variant
      Dim i As Long
      Dim x As Long
      Dim m As Long
       
       
      Dim tmp As Variant
      Dim tmp1 As String
       
      m = 0
      x = 0
       
      If MinMax = 0 Then 'минимум
       
      If SW_Type = 0 Then
       
      max_val = CDate("01.01.4099")
       
      Else
       
      max_val = Val(10000)
       
       
      End If
       
       
      Else
       
       
      If SW_Type = 0 Then
       
      max_val = CDate("01.01.1099")
      Else
       
      max_val = Val(-9999)
       
       
      End If
       
       
      End If
       
       
      M4:
       
      For i = m To UBound(in_arr)
       
      tmp = ParseStrDIV(Chr(9) & in_arr(i) & Chr(9), Chr(9), Chr(9), NmbStlb - 1)
       
      If MinMax = 0 Then 'минимум
       
      If SW_Type = 0 Then
       
      tmp = CDate(tmp)
      Else
       
      tmp = Val(tmp)
       
      End If
       
       
      If (tmp < max_val) Then
      max_val = tmp
      x = i
      End If
      Else
      If (tmp > max_val) Then
      max_val = tmp
      x = i
      End If
      End If
       
      Next i
        
      in_arr(x) = in_arr(m)
        
      in_arr(m) = ReplaceCell_InStr(in_arr(m), NmbStlb, CStr(max_val))
        
      If MinMax = 0 Then 'минимум
      If SW_Type = 0 Then
       
      max_val = CDate("01.01.4099")
       
      Else
       
      max_val = Val(10000)
       
       
      End If
       
      Else
       
      If SW_Type = 0 Then
       
      max_val = CDate("01.01.1099")
      Else
       
      max_val = Val(-9999)
       
      End If
      End If
      m = m + 1
      If m <= UBound(in_arr) Then GoTo M4
       
      SortArrayMinMaxZnV1 = in_arr
       
      End Function
       
      Public Function ParseStrDIV(ByVal sourc_str As String, ByVal str_div1 As String, ByVal str_div2 As String, ByVal PN As Integer) As String
       
      Dim p As Integer
      Dim m As Integer
       
      PN = PN + 1
       
      If str_div1 = vbNullString Then
      m = 1
      GoTo M4
      End If
       
      If str_div2 = vbNullString Then
      p = Len(sourc_str)
      m = CountInSTR(sourc_str, str_div1, PN) + 1
      ParseStrDIV = Mid(sourc_str, m, p)
      Exit Function
      End If
       
      m = CountInSTR(sourc_str, str_div1, PN) + 1
       
      M4:
       
      If m = 1 Then
      p = CountInSTR(sourc_str, str_div2, PN) + 1
      Else
      p = CountInSTR(sourc_str, str_div2, PN + 1) + 1
      If m > p Then p = CountInSTR(sourc_str, str_div2, PN - 1) + 1
      End If
       
      If m = p Then
      ParseStrDIV = Mid(sourc_str, m, Len(sourc_str) - m + 1)
      Else
       
      If Len(str_div1) > 1 And Len(str_div2) > 1 Then
      ParseStrDIV = Mid(sourc_str, Len(str_div1) + 1, p - Len(str_div2) - 1)
      Else
      ParseStrDIV = Mid(sourc_str, m, p - m - 1)
      End If
       
      End If
       
       
      End Function
       
      Public Function ReplaceCell_InStr(ByVal str_dat As String, ByVal NumbStlb As Byte, ByVal repl_dat As String) As String
       
       
       
       
      Dim i As Long
       
      Dim lft_s As String
      Dim rgt_s As String
       
      Dim sum_s As String
       
      'Dim tmp_s As String
       
      'Dim len_str As Integer
       
      'str_dat = Chr(9) & str_dat & Chr(9)
       
      'If NumbStlb = 1 Then NumbStlb = 0
       
      'len_str = CountInSTR(str_dat, Chr(9), NumbStlb)
       
      lft_s = ParseStrDIV(Chr(9) & str_dat, vbNullString, Chr(9), NumbStlb - 1)
       
       
      'If NumbStlb = 0 Then NumbStlb = 1
      rgt_s = ParseStrDIV(Chr(9) & str_dat & Chr(9), Chr(9), vbNullString, NumbStlb)
       
      sum_s = Replace(lft_s & Chr(9) & repl_dat & Chr(9) & rgt_s, Chr(9) & Chr(9), Chr(9))
       
      'if
       
      'If ParseStrDIV(sum_s, Chr(9), vbNullString, 0) = Chr(9) Then sum_s = Left(sum_s, Len(sum_s) - 1)
      'If ParseStrDIV(sum_s, vbNullString, Chr(9), 0) = Chr(9) Then sum_s = Right(sum_s, Len(sum_s) - 1)
       
      ReplaceCell_InStr = sum_s 'Replace(lft_s & Chr(9) & repl_dat & Chr(9) & rgt_s, Chr(9) & Chr(9), Chr(9))
       
      End Function
       
      Public Function CountInSTR(ByVal str As String, ByVal find_str As String, Optional ByVal p_numb As Long = 0) As Long
       
      Dim x As Long
      Dim cnt_count As Long
      Dim tmp_temp As Long
       
      'x = InStr(1, str, find_str)
       
      ' p_numb - ģīęķī óźąēąņü ķīģåš żėåģåķņą ļī ń÷øņó ā ńņšīźå, ÷ņīįū ļīėó÷čņü äėčķó äī ķåćī
       
      'Dim y As Long
       
      If p_numb = 0 Then p_numb = Len(str)
       
       
      For x = 1 To p_numb 'Len(str)
       
      cnt_count = InStr(cnt_count + 1, str, find_str)
      If cnt_count = 0 Then Exit For
      tmp_temp = cnt_count
      'y = y + 1
      Next x
       
      CountInSTR = tmp_temp
       
      End Function
       
      '//Сам код------------------------------------
      Не, вот ты всерьёз думаешь, что кто-то станет разбираться в этой твоей некомментированной и неформатированной портянке?
        Цитата Akina @
        Не, вот ты всерьёз думаешь, что кто-то станет разбираться в этой твоей некомментированной и неформатированной портянке?

        тут только 1 ф-я отвечает за сортировку, остальные можно не смотреть, они служебные, я их для компиляции дал

        ExpandedWrap disabled
          Public Function SortArrayMinMaxZnV1(ByRef in_arr() As String, ByVal MinMax As LogVar, ByVal NmbStlb As Byte, ByVal SW_Type As Boolean) As String()
           
          'SW_Type=1 - сортировка по числам, 0- по дате
           
          Dim max_val As Variant
          Dim i As Long
          Dim x As Long
          Dim m As Long
           
          Dim tmp As Variant
          Dim tmp1 As String
           
          m = 0
          x = 0
           
          If MinMax = 0 Then 'минимум
           
          If SW_Type = 0 Then
           
          max_val = CDate("01.01.4099")
           
          Else
           
          max_val = Val(10000)
           
          End If
           
          Else
           
           
          If SW_Type = 0 Then
           
          max_val = CDate("01.01.1099")
          Else
           
          max_val = Val(-9999)
           
          End If
           
          End If
           
           
          M4:
           
          For i = m To UBound(in_arr)
           
          tmp = ParseStrDIV(Chr(9) & in_arr(i) & Chr(9), Chr(9), Chr(9), NmbStlb - 1)
           
          If MinMax = 0 Then 'минимум
           
          If SW_Type = 0 Then
           
          tmp = CDate(tmp)
          Else
           
          tmp = Val(tmp)
           
          End If
           
           
          If (tmp < max_val) Then
          max_val = tmp
          x = i
          End If
          Else
          If (tmp > max_val) Then
          max_val = tmp
          x = i
          End If
          End If
           
          Next i
           
          in_arr(x) = in_arr(m)
           
          in_arr(m) = ReplaceCell_InStr(in_arr(m), NmbStlb, CStr(max_val))
           
          If MinMax = 0 Then 'минимум
          If SW_Type = 0 Then
           
          max_val = CDate("01.01.4099")
           
          Else
           
          max_val = Val(10000)
           
          End If
           
          Else
           
          If SW_Type = 0 Then
           
          max_val = CDate("01.01.1099")
          Else
           
          max_val = Val(-9999)
           
          End If
          End If
           
          m = m + 1
          If m <= UBound(in_arr) Then GoTo M4
           
          SortArrayMinMaxZnV1 = in_arr
           
          End Function
          ExpandedWrap disabled
            ByRef in_arr() As String

          А на что тебе ООП? Загнал бы всё в модель Row а не в виде строк...
            Ну да, стало короче. Теперь ещё исправить бы вот эти недостатки:
            Цитата Akina @
            некомментированной

            Цитата Akina @
            неформатированной


            Ну и хотя бы указать, какой из многочисленных методов сортировки тут использован. И какой используется формат входных данных.

            Хотя я бы предложил всё это нахрен выбросить и сделать заново. Ориентируясь на сортировку пользовательского типа данных (это может быть и массив пользовательского типа, и многомерный массив, и сериализованная строка, и вообще что угодно), для чего достаточно к любому стандартному коду сортировки добавить два кусочка (функцию сравнения двух элементов и процедуру их обмена) и использовать их в соотв. местах кода.
              Добавлено
              Цитата VisualProg @
              ExpandedWrap disabled
                ByRef in_arr() As String

              А на что тебе ООП? Загнал бы всё в модель Row а не в виде строк...

              не совсем знаком с этим, плюс не хотел заморачиваться

              Добавлено
              Цитата Akina @
              Ну да, стало короче. Теперь ещё исправить бы вот эти недостатки:
              Цитата Akina @
              некомментированной

              Цитата Akina @
              неформатированной


              Ну и хотя бы указать, какой из многочисленных методов сортировки тут использован. И какой используется формат входных данных.

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

              не мой код, я думаю, хотя не помню уже
              Сообщение отредактировано: salieri -
                Цитата salieri @
                не совсем знаком с этим, плюс не хотел заморачиваться

                ИМХО, в этом то и проблема :D

                Половина твоего метода - это парсинг и преобразования, а не сортировка. Так, что, я бы сказал - основная ошибка в том, что это винегрет а не функция сортировки.

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

                  ExpandedWrap disabled
                    Sub Sort_(Arr() As String, nCol As Integer)
                     
                        s% = LBound(Arr, 1)
                        e% = UBound(Arr, 1)
                        
                        For i% = s% To e% - 1
                            For j% = i% + 1 To e%
                                If CDate(Arr(i%, nCol%)) > CDate(Arr(j%, nCol%)) Then
                                   For k% = LBound(Arr, 2) To UBound(Arr, 2)
                                       tmp$ = Arr(i%, k%)
                                       Arr(i%, k%) = Arr(j%, k%)
                                       Arr(j%, k%) = tmp$
                                   Next k%
                                End If
                            Next j%
                        Next i%
                     
                    End Sub
                     
                    Sub Test()
                     
                    Dim X(1 To 3, 1 To 3) As String
                     
                        X(1, 1) = "01.01.2028"
                        X(1, 2) = "01.01.2017"
                        X(1, 3) = "123"
                        X(2, 1) = "01.02.2014"
                        X(2, 2) = "05.07.2014"
                        X(2, 3) = "456"
                        X(3, 1) = "01.05.2026"
                        X(3, 2) = "07.01.2019"
                        X(3, 3) = "000"
                     
                        Debug.Print "Сортировка по 1-й колонке"
                        Debug.Print
                     
                        Sort_ X, 1
                     
                        For i% = 1 To 3
                            For j% = 1 To 3
                                Debug.Print X(i%, j%); " ";
                            Next j%
                            Debug.Print
                        Next i%
                     
                        Debug.Print
                        Debug.Print "Сортировка по 2-й колонке"
                        Debug.Print
                        
                        Sort_ X, 2
                     
                        For i% = 1 To 3
                            For j% = 1 To 3
                                Debug.Print X(i%, j%); " ";
                            Next j%
                            Debug.Print
                        Next i%
                     
                        Debug.Print
                        
                    End Sub
                    Цитата VisualProg @
                    (для этого надо будет оперировать функцией-компаратором)

                    Рисовать на VB непривязанные коллбэки - неблагодарное занятие...
                      Что хотел, написал. Всем спасибо за помощь! Я очень благодарен. :)

                      ExpandedWrap disabled
                        Public Function SortArray(ByRef in_arr() As String, ByVal MinMax As LogVar, ByVal NumStlb As Byte, ByVal SW_Type As LogVar) As String()
                         
                        'SW_Type=0 - сортировка по числам, 1- по дате
                        'MinMax=0 - убывание, 1 - возрастание
                         
                        Dim m As Long
                         
                        Dim x As Variant
                        Dim i As Long
                        Dim tmp_i As Long
                         
                        Dim tmp_s As String
                         
                        Dim sourc_in_arr() As String
                         
                         
                        ReDim sourc_in_arr(UBound(in_arr)) As String
                         
                        For i = 0 To UBound(in_arr)
                         
                        sourc_in_arr(i) = in_arr(i)
                         
                         
                        Next i
                         
                        'Erase ArrDat
                        Del_ArrDat
                         
                        tmp_i = 0
                        'x = 0
                        m = 0
                         
                         
                        'If in_arr(tmp_i) <> vbNullString Then x = Val(in_arr(tmp_i))
                         
                        NumStlb = NumStlb - 1 '-1
                         
                        M4:
                         
                        If MinMax = 0 Then
                         
                        If SW_Type = 0 Then
                        x = Val(-999999)
                        Else
                        x = CDate("01.01.1900")
                        End If
                         
                        Else
                         
                        If SW_Type = 0 Then
                        x = Val(999999)
                        Else
                        x = CDate("01.01.2090")
                        End If
                         
                        End If
                         
                        'MsgBox in_arr(7)
                         
                        For i = 0 To UBound(sourc_in_arr)
                         
                        tmp_s = ParseStrDIV_V1(Chr(9) & sourc_in_arr(i) & Chr(9), Chr(9), Chr(9), NumStlb, NumStlb)
                         
                        If tmp_s <> vbNullString Then
                         
                        If MinMax = 0 Then
                         
                        If SW_Type = 0 Then
                         
                        If Val(tmp_s) > Val(x) Then
                        x = Val(tmp_s)
                        tmp_i = i
                        End If
                         
                        Else
                         
                        If CDate(tmp_s) > CDate(x) Then
                        x = CDate(tmp_s)
                        tmp_i = i
                        End If
                         
                        End If
                         
                        Else
                         
                        If SW_Type = 0 Then
                         
                        If Val(tmp_s) < Val(x) Then
                        x = Val(tmp_s)
                        tmp_i = i
                        End If
                         
                        Else
                         
                        If CDate(tmp_s) < CDate(x) Then
                        x = CDate(tmp_s)
                        tmp_i = i
                        End If
                         
                        End If
                         
                        End If
                         
                        End If
                         
                        Next i
                         
                        '''ReplaceCell_InStr in_arr(tmp_i), NumStlb, vbNullString 'CStr(x)
                        '''in_arr(tmp_i) = vbNullString
                         
                         
                        Add_ArrDat sourc_in_arr(tmp_i) 'CStr(x)
                        sourc_in_arr(tmp_i) = vbNullString
                         
                        m = m + 1
                        If m <= UBound(sourc_in_arr) Then GoTo M4
                         
                        SortArray = ArrDat '_OUT
                         
                        End Function
                         
                        Public Function ParseStrDIV_V1(ByVal sourc_str As String, ByVal str_div1 As String, ByVal str_div2 As String, ByVal PN1 As Integer, ByVal PN2 As Integer) As String  '()
                         
                        Dim p As Integer
                        Dim m As Integer
                         
                        PN1 = PN1 + 1
                        PN2 = PN2 + 1
                         
                        If str_div1 = vbNullString Then
                        m = 1
                        GoTo M4
                        End If
                         
                        If str_div2 = vbNullString Then
                        p = Len(sourc_str)
                        m = CountInSTR(sourc_str, str_div1, PN1) + 1
                        ParseStrDIV_V1 = Mid(sourc_str, m, p)
                        Exit Function
                        End If
                         
                        m = CountInSTR(sourc_str, str_div1, PN1) + 1
                         
                        M4:
                         
                        If m = 1 Then
                        p = CountInSTR(sourc_str, str_div2, PN2) + 1
                        Else
                        p = CountInSTR(sourc_str, str_div2, PN2 + 1) + 1
                        If m > p Then p = CountInSTR(sourc_str, str_div2, PN1 - 1) + 1
                        End If
                         
                        If m = p Then
                        ParseStrDIV_V1 = Mid(sourc_str, m, Len(sourc_str) - m + 1)
                        Else
                         
                        If Len(str_div1) > 1 And Len(str_div2) > 1 Then
                        ParseStrDIV_V1 = Mid(sourc_str, Len(str_div1) + 1, p - Len(str_div2) - 1)
                        Else
                        ParseStrDIV_V1 = Mid(sourc_str, m, p - m - 1)
                        End If
                         
                        End If
                         
                         
                        End Function
                         
                        Public Sub Del_ArrDat() 'As String()
                         
                        'Static count_arr As Long
                         
                         
                        ReDim ArrDat(0) As String
                        ArrDat(0) = vbNullString 'var_dat
                        'count_arr = count_arr + 1
                        Erase ArrDat
                         
                        'AddArrDat = ArrDat
                         
                        End Sub
                         
                        Public Sub Add_ArrDat(ByVal var_dat As String) 'As String()
                         
                        Static count_arr As Long
                         
                         
                        ReDim Preserve ArrDat(count_arr) As String
                        ArrDat(count_arr) = var_dat
                        count_arr = count_arr + 1
                         
                         
                        'AddArrDat = ArrDat
                         
                        End Sub
                      0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
                      0 пользователей:


                      Рейтинг@Mail.ru
                      [ Script execution time: 0,0493 ]   [ 17 queries used ]   [ Generated: 19.03.24, 11:19 GMT ]